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 make strings
   5 math math.parser sequences assocs arrays splitting combinators
   6 unicode.case accessors fry ascii ;
   7 IN: xml.tokenize
   8
   9 ! XML namespace processing: ns = namespace
  10
  11 ! A stack of hashtables
  12 SYMBOL: ns-stack
  13
  14 : attrs>ns ( attrs-alist -- hash )
  15     ! this should check to make sure URIs are valid
  16     [
  17         [
  18             swap dup space>> "xmlns" =
  19             [ main>> set ]
  20             [
  21                 T{ name f "" "xmlns" f } names-match?
  22                 [ "" set ] [ drop ] if
  23             ] if
  24         ] assoc-each
  25     ] { } make-assoc f like ;
  26
  27 : add-ns ( name -- )
  28     dup space>> dup ns-stack get assoc-stack
  29     [ nip ] [ nonexist-ns ] if* >>url drop ;
  30
  31 : push-ns ( hash -- )
  32     ns-stack get push ;
  33
  34 : pop-ns ( -- )
  35     ns-stack get pop* ;
  36
  37 : init-ns-stack ( -- )
  38     V{ H{
  39         { "xml" "http://www.w3.org/XML/1998/namespace" }
  40         { "xmlns" "http://www.w3.org/2000/xmlns" }
  41         { "" "" }
  42     } } clone
  43     ns-stack set ;
  44
  45 : tag-ns ( name attrs-alist -- name attrs )
  46     dup attrs>ns push-ns
  47     [ dup add-ns ] dip dup [ drop add-ns ] assoc-each <attrs> ;
  48
  49 ! Parsing names
  50
  51 : version=1.0? ( -- ? )
  52     prolog-data get version>> "1.0" = ;
  53
  54 ! version=1.0? is calculated once and passed around for efficiency
  55
  56 : (parse-name) ( -- str )
  57     version=1.0? dup
  58     get-char name-start? [
  59         [ dup get-char name-char? not ] take-until nip
  60     ] [
  61         "Malformed name" xml-string-error
  62     ] if ;
  63
  64 : parse-name ( -- name )
  65     (parse-name) get-char CHAR: : =
  66     [ next (parse-name) ] [ "" swap ] if f <name> ;
  67
  68 !   -- Parsing strings
  69
  70 : (parse-entity) ( string -- )
  71     dup entities at [ , ] [
  72         prolog-data get standalone>>
  73         [ no-entity ] [
  74             dup extra-entities get at
  75             [ , ] [ no-entity ] ?if
  76         ] if
  77     ] ?if ;
  78
  79 : parse-entity ( -- )
  80     next CHAR: ; take-char next
  81     "#" ?head [
  82         "x" ?head 16 10 ? base> ,
  83     ] [ (parse-entity) ] if ;
  84
  85 : (parse-char) ( ch -- )
  86     get-char {
  87         { [ dup not ] [ 2drop ] }
  88         { [ 2dup = ] [ 2drop next ] }
  89         { [ dup CHAR: & = ] [ drop parse-entity (parse-char) ] }
  90         [ , next (parse-char) ]
  91     } cond ;
  92
  93 : parse-char ( ch -- string )
  94     [ (parse-char) ] "" make ;
  95
  96 : parse-quot ( ch -- string )
  97     parse-char get-char
  98     [ "XML file ends in a quote" xml-string-error ] unless ;
  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-attr-value ( -- seq )
 111     get-char dup "'\"" member? [
 112         next parse-quot
 113     ] [
 114         "Attribute lacks quote" xml-string-error
 115     ] if ;
 116
 117 : parse-attr ( -- )
 118     [ parse-name ] with-scope
 119     pass-blank CHAR: = expect pass-blank
 120     [ parse-attr-value ] with-scope
 121     2array , ;
 122
 123 : (middle-tag) ( -- )
 124     pass-blank version=1.0? get-char name-start?
 125     [ parse-attr (middle-tag) ] when ;
 126
 127 : middle-tag ( -- attrs-alist )
 128     ! f make will make a vector if it has any elements
 129     [ (middle-tag) ] f make pass-blank ;
 130
 131 : end-tag ( name attrs-alist -- tag )
 132     tag-ns pass-blank get-char CHAR: / =
 133     [ pop-ns <contained> next ] [ <opener> ] if ;
 134
 135 : take-comment ( -- comment )
 136     "--" expect-string
 137     "--" take-string
 138     <comment>
 139     CHAR: > expect ;
 140
 141 : take-cdata ( -- string )
 142     "[CDATA[" expect-string "]]>" take-string ;
 143
 144 : take-element-decl ( -- element-decl )
 145     pass-blank " " take-string pass-blank ">" take-string <element-decl> ;
 146
 147 : take-attlist-decl ( -- doctype-decl )
 148     pass-blank " " take-string pass-blank ">" take-string <attlist-decl> ;
 149
 150 : take-until-one-of ( seps -- str sep )
 151     '[ get-char _ member? ] take-until get-char ;
 152
 153 : only-blanks ( str -- )
 154     [ blank? ] all? [ bad-doctype-decl ] unless ;
 155
 156 : take-system-literal ( -- str )
 157     pass-blank get-char next {
 158         { CHAR: ' [ "'" take-string ] }
 159         { CHAR: " [ "\"" take-string ] }
 160     } case ;
 161
 162 : take-system-id ( -- system-id )
 163     take-system-literal <system-id>
 164     ">" take-string only-blanks ;
 165
 166 : take-public-id ( -- public-id )
 167     take-system-literal
 168     take-system-literal <public-id>
 169     ">" take-string only-blanks ;
 170
 171 DEFER: direct
 172
 173 : (take-internal-subset) ( -- )
 174     pass-blank get-char {
 175         { CHAR: ] [ next ] }
 176         [ drop "<!" expect-string direct , (take-internal-subset) ]
 177     } case ;
 178
 179 : take-internal-subset ( -- seq )
 180     [ (take-internal-subset) ] { } make ;
 181
 182 : (take-external-id) ( token -- external-id )
 183     pass-blank {
 184         { "SYSTEM" [ take-system-id ] }
 185         { "PUBLIC" [ take-public-id ] }
 186         [ bad-external-id ]
 187     } case ;
 188
 189 : take-external-id ( -- external-id )
 190     " " take-string (take-external-id) ;
 191
 192 : take-doctype-decl ( -- doctype-decl )
 193     pass-blank " >" take-until-one-of {
 194         { CHAR: \s [
 195             pass-blank get-char CHAR: [ = [
 196                 next take-internal-subset f swap
 197                 ">" take-string only-blanks
 198             ] [
 199                 " >" take-until-one-of {
 200                     { CHAR: \s [ (take-external-id) ] }
 201                     { CHAR: > [ only-blanks f ] }
 202                 } case f
 203             ] if
 204         ] }
 205         { CHAR: > [ f f ] }
 206     } case <doctype-decl> ;
 207
 208 : take-entity-def ( -- entity-name entity-def )
 209     " " take-string pass-blank get-char {
 210         { CHAR: ' [ take-system-literal ] }
 211         { CHAR: " [ take-system-literal ] }
 212         [ drop take-external-id ]
 213     } case ;
 214
 215 : take-entity-decl ( -- entity-decl )
 216     pass-blank get-char {
 217         { CHAR: % [ next pass-blank take-entity-def ] }
 218         [ drop take-entity-def ]
 219     } case
 220     ">" take-string only-blanks <entity-decl> ;
 221
 222 : take-directive ( -- directive )
 223     " " take-string {
 224         { "ELEMENT" [ take-element-decl ] }
 225         { "ATTLIST" [ take-attlist-decl ] }
 226         { "DOCTYPE" [ take-doctype-decl ] }
 227         { "ENTITY" [ take-entity-decl ] }
 228         [ bad-directive ]
 229     } case ;
 230
 231 : direct ( -- object )
 232     get-char {
 233         { CHAR: - [ take-comment ] }
 234         { CHAR: [ [ take-cdata ] }
 235         [ drop take-directive ]
 236     } case ;
 237
 238 : yes/no>bool ( string -- t/f )
 239     {
 240         { "yes" [ t ] }
 241         { "no" [ f ] }
 242         [ not-yes/no ]
 243     } case ;
 244
 245 : assure-no-extra ( seq -- )
 246     [ first ] map {
 247         T{ name f "" "version" f }
 248         T{ name f "" "encoding" f }
 249         T{ name f "" "standalone" f }
 250     } diff
 251     [ extra-attrs ] unless-empty ;
 252
 253 : good-version ( version -- version )
 254     dup { "1.0" "1.1" } member? [ bad-version ] unless ;
 255
 256 : prolog-attrs ( alist -- prolog )
 257     [ T{ name f "" "version" f } swap at
 258       [ good-version ] [ versionless-prolog ] if* ] keep
 259     [ T{ name f "" "encoding" f } swap at
 260       "UTF-8" or ] keep
 261     T{ name f "" "standalone" f } swap at
 262     [ yes/no>bool ] [ f ] if*
 263     <prolog> ;
 264
 265 : parse-prolog ( -- prolog )
 266     pass-blank middle-tag "?>" expect-string
 267     dup assure-no-extra prolog-attrs
 268     dup prolog-data set ;
 269
 270 : instruct ( -- instruction )
 271     (parse-name) dup "xml" =
 272     [ drop parse-prolog ] [
 273         dup >lower "xml" =
 274         [ capitalized-prolog ]
 275         [ "?>" take-string append <instruction> ] if
 276     ] if ;
 277
 278 : make-tag ( -- tag )
 279     {
 280         { [ get-char dup CHAR: ! = ] [ drop next direct ] }
 281         { [ CHAR: ? = ] [ next instruct ] }
 282         [
 283             start-tag [ dup add-ns pop-ns <closer> ]
 284             [ middle-tag end-tag ] if
 285             CHAR: > expect
 286         ]
 287     } cond ;