basis/xml/elements/elements.factor

   1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel namespaces xml.tokenize xml.state xml.name
   4 xml.data accessors arrays make xml.char-classes fry assocs sequences
   5 math xml.errors sets combinators io.encodings io.encodings.iana
   6 unicode.case xml.dtd strings ;
   7 IN: xml.elements
   8
   9 : parse-attr ( -- )
  10     parse-name pass-blank CHAR: = expect pass-blank
  11     t parse-quote* 2array , ;
  12
  13 : start-tag ( -- name ? )
  14     #! Outputs the name and whether this is a closing tag
  15     get-char CHAR: / = dup [ next ] when
  16     parse-name swap ;
  17
  18 : (middle-tag) ( -- )
  19     pass-blank version=1.0? get-char name-start?
  20     [ parse-attr (middle-tag) ] when ;
  21
  22 : assure-no-duplicates ( attrs-alist -- attrs-alist )
  23     H{ } clone 2dup '[ swap _ push-at ] assoc-each
  24     [ nip length 2 >= ] assoc-filter >alist
  25     [ first first2 duplicate-attr ] unless-empty ;
  26
  27 : middle-tag ( -- attrs-alist )
  28     ! f make will make a vector if it has any elements
  29     [ (middle-tag) ] f make pass-blank
  30     assure-no-duplicates ;
  31
  32 : end-tag ( name attrs-alist -- tag )
  33     tag-ns pass-blank get-char CHAR: / =
  34     [ pop-ns <contained> next CHAR: > expect ]
  35     [ depth inc <opener> close ] if ;
  36
  37 : take-comment ( -- comment )
  38     "--" expect-string
  39     "--" take-string
  40     <comment>
  41     CHAR: > expect ;
  42
  43 : assure-no-extra ( seq -- )
  44     [ first ] map {
  45         T{ name f "" "version" f }
  46         T{ name f "" "encoding" f }
  47         T{ name f "" "standalone" f }
  48     } diff
  49     [ extra-attrs ] unless-empty ;
  50
  51 : good-version ( version -- version )
  52     dup { "1.0" "1.1" } member? [ bad-version ] unless ;
  53
  54 : prolog-version ( alist -- version )
  55     T{ name f "" "version" f } swap at
  56     [ good-version ] [ versionless-prolog ] if* ;
  57
  58 : prolog-encoding ( alist -- encoding )
  59     T{ name f "" "encoding" f } swap at "UTF-8" or ;
  60
  61 : yes/no>bool ( string -- t/f )
  62     {
  63         { "yes" [ t ] }
  64         { "no" [ f ] }
  65         [ not-yes/no ]
  66     } case ;
  67
  68 : prolog-standalone ( alist -- version )
  69     T{ name f "" "standalone" f } swap at
  70     [ yes/no>bool ] [ f ] if* ;
  71
  72 : prolog-attrs ( alist -- prolog )
  73     [ prolog-version ]
  74     [ prolog-encoding ]
  75     [ prolog-standalone ]
  76     tri <prolog> ;
  77
  78 SYMBOL: string-input?
  79 : decode-input-if ( encoding -- )
  80     string-input? get [ drop ] [ decode-input ] if ;
  81
  82 : parse-prolog ( -- prolog )
  83     pass-blank middle-tag "?>" expect-string
  84     dup assure-no-extra prolog-attrs
  85     dup encoding>> dup "UTF-16" =
  86     [ drop ] [ name>encoding [ decode-input-if ] when* ] if
  87     dup prolog-data set ;
  88
  89 : instruct ( -- instruction )
  90     take-name {
  91         { [ dup "xml" = ] [ drop parse-prolog ] }
  92         { [ dup >lower "xml" = ] [ capitalized-prolog ] }
  93         { [ dup valid-name? not ] [ bad-name ] }
  94         [ "?>" take-string append <instruction> ]
  95     } cond ;
  96
  97 : take-cdata ( -- string )
  98     depth get zero? [ bad-cdata ] when
  99     "[CDATA[" expect-string "]]>" take-string ;
 100
 101 DEFER: make-tag ! Is this unavoidable?
 102
 103 : expand-pe ( -- ) ; ! Make this run the contents of the pe within a DOCTYPE
 104
 105 : (take-internal-subset) ( -- )
 106     pass-blank get-char {
 107         { CHAR: ] [ next ] }
 108         { CHAR: % [ expand-pe ] }
 109         { CHAR: < [
 110             next make-tag dup dtd-acceptable?
 111             [ bad-doctype ] unless , (take-internal-subset)
 112         ] }
 113         [ 1string bad-doctype ]
 114     } case ;
 115
 116 : take-internal-subset ( -- seq )
 117     [
 118         H{ } pe-table set
 119         t in-dtd? set
 120         (take-internal-subset)
 121     ] { } make ;
 122
 123 : nontrivial-doctype ( -- external-id internal-subset )
 124     pass-blank get-char CHAR: [ = [
 125         next take-internal-subset f swap close
 126     ] [
 127         " >" take-until-one-of {
 128             { CHAR: \s [ (take-external-id) ] }
 129             { CHAR: > [ only-blanks f ] }
 130         } case f
 131     ] if ;
 132
 133 : take-doctype-decl ( -- doctype-decl )
 134     pass-blank " >" take-until-one-of {
 135         { CHAR: \s [ nontrivial-doctype ] }
 136         { CHAR: > [ f f ] }
 137     } case <doctype-decl> ;
 138
 139 : take-directive ( -- doctype )
 140     take-name dup "DOCTYPE" =
 141     [ drop take-doctype-decl ] [
 142         in-dtd? get
 143         [ take-inner-directive ]
 144         [ misplaced-directive ] if
 145     ] if ;
 146
 147 : direct ( -- object )
 148     get-char {
 149         { CHAR: - [ take-comment ] }
 150         { CHAR: [ [ take-cdata ] }
 151         [ drop take-directive ]
 152     } case ;
 153
 154 : make-tag ( -- tag )
 155     {
 156         { [ get-char dup CHAR: ! = ] [ drop next direct ] }
 157         { [ CHAR: ? = ] [ next instruct ] }
 158         [
 159             start-tag [ dup add-ns pop-ns <closer> depth dec close ]
 160             [ middle-tag end-tag ] if
 161         ]
 162     } cond ;