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 xml.entities unicode.categories ;
   7 IN: xml.elements
   8
   9 : take-interpolated ( quot -- interpolated )
  10     interpolating? get [
  11         drop get-char CHAR: > =
  12         [ next f ]
  13         [ "->" take-string [ blank? ] trim ]
  14         if <interpolated>
  15     ] [ call ] if ; inline
  16
  17 : interpolate-quote ( -- interpolated )
  18     [ quoteless-attr ] take-interpolated ;
  19
  20 : parse-attr ( -- )
  21     parse-name pass-blank "=" expect pass-blank
  22     get-char CHAR: < =
  23     [ "<-" expect interpolate-quote ]
  24     [ t parse-quote* ] if 2array , ;
  25
  26 : start-tag ( -- name ? )
  27     #! Outputs the name and whether this is a closing tag
  28     get-char CHAR: / = dup [ next ] when
  29     parse-name swap ;
  30
  31 : (middle-tag) ( -- )
  32     pass-blank version=1.0? get-char name-start?
  33     [ parse-attr (middle-tag) ] when ;
  34
  35 : assure-no-duplicates ( attrs-alist -- attrs-alist )
  36     H{ } clone 2dup '[ swap _ push-at ] assoc-each
  37     [ nip length 2 >= ] assoc-filter >alist
  38     [ first first2 duplicate-attr ] unless-empty ;
  39
  40 : middle-tag ( -- attrs-alist )
  41     ! f make will make a vector if it has any elements
  42     [ (middle-tag) ] f make pass-blank
  43     assure-no-duplicates ;
  44
  45 : end-tag ( name attrs-alist -- tag )
  46     tag-ns pass-blank get-char CHAR: / =
  47     [ pop-ns <contained> next ">" expect ]
  48     [ depth inc <opener> close ] if ;
  49
  50 : take-comment ( -- comment )
  51     "--" expect
  52     "--" take-string
  53     <comment>
  54     ">" expect ;
  55
  56 : assure-no-extra ( seq -- )
  57     [ first ] map {
  58         T{ name f "" "version" f }
  59         T{ name f "" "encoding" f }
  60         T{ name f "" "standalone" f }
  61     } diff
  62     [ extra-attrs ] unless-empty ;
  63
  64 : good-version ( version -- version )
  65     dup { "1.0" "1.1" } member? [ bad-version ] unless ;
  66
  67 : prolog-version ( alist -- version )
  68     T{ name f "" "version" f } swap at
  69     [ good-version ] [ versionless-prolog ] if* ;
  70
  71 : prolog-encoding ( alist -- encoding )
  72     T{ name f "" "encoding" f } swap at "UTF-8" or ;
  73
  74 : yes/no>bool ( string -- t/f )
  75     {
  76         { "yes" [ t ] }
  77         { "no" [ f ] }
  78         [ not-yes/no ]
  79     } case ;
  80
  81 : prolog-standalone ( alist -- version )
  82     T{ name f "" "standalone" f } swap at
  83     [ yes/no>bool ] [ f ] if* ;
  84
  85 : prolog-attrs ( alist -- prolog )
  86     [ prolog-version ]
  87     [ prolog-encoding ]
  88     [ prolog-standalone ]
  89     tri <prolog> ;
  90
  91 SYMBOL: string-input?
  92 : decode-input-if ( encoding -- )
  93     string-input? get [ drop ] [ decode-input ] if ;
  94
  95 : parse-prolog ( -- prolog )
  96     pass-blank middle-tag "?>" expect
  97     dup assure-no-extra prolog-attrs
  98     dup encoding>> dup "UTF-16" =
  99     [ drop ] [ name>encoding [ decode-input-if ] when* ] if
 100     dup prolog-data set ;
 101
 102 : instruct ( -- instruction )
 103     take-name {
 104         { [ dup "xml" = ] [ drop parse-prolog ] }
 105         { [ dup >lower "xml" = ] [ capitalized-prolog ] }
 106         { [ dup valid-name? not ] [ bad-name ] }
 107         [ "?>" take-string append <instruction> ]
 108     } cond ;
 109
 110 : take-cdata ( -- string )
 111     depth get zero? [ bad-cdata ] when
 112     "[CDATA[" expect "]]>" take-string ;
 113
 114 DEFER: make-tag ! Is this unavoidable?
 115
 116 : expand-pe ( -- ) ; ! Make this run the contents of the pe within a DOCTYPE
 117
 118 : dtd-loop ( -- )
 119     pass-blank get-char {
 120         { CHAR: ] [ next ] }
 121         { CHAR: % [ expand-pe ] }
 122         { CHAR: < [
 123             next make-tag dup dtd-acceptable?
 124             [ bad-doctype ] unless , dtd-loop
 125         ] }
 126         { f [ ] }
 127         [ 1string bad-doctype ]
 128     } case ;
 129
 130 : take-internal-subset ( -- dtd )
 131     [
 132         H{ } clone pe-table set
 133         t in-dtd? set
 134         dtd-loop
 135         pe-table get
 136     ] { } make swap extra-entities get swap <dtd> ;
 137
 138 : take-optional-id ( -- id/f )
 139     get-char "SP" member?
 140     [ take-external-id ] [ f ] if ;
 141
 142 : take-internal ( -- dtd/f )
 143     get-char CHAR: [ =
 144     [ next take-internal-subset ] [ f ] if ;
 145
 146 : take-doctype-decl ( -- doctype-decl )
 147     pass-blank take-name
 148     pass-blank take-optional-id
 149     pass-blank take-internal
 150     <doctype-decl> close ;
 151
 152 : take-directive ( -- doctype )
 153     take-name dup "DOCTYPE" =
 154     [ drop take-doctype-decl ] [
 155         in-dtd? get
 156         [ take-inner-directive ]
 157         [ misplaced-directive ] if
 158     ] if ;
 159
 160 : direct ( -- object )
 161     get-char {
 162         { CHAR: - [ take-comment ] }
 163         { CHAR: [ [ take-cdata ] }
 164         [ drop take-directive ]
 165     } case ;
 166
 167 : normal-tag ( -- tag )
 168     start-tag
 169     [ dup add-ns pop-ns <closer> depth dec close ]
 170     [ middle-tag end-tag ] if ;
 171
 172 : interpolate-tag ( -- interpolated )
 173     [ "-" bad-name ] take-interpolated ;
 174
 175 : make-tag ( -- tag )
 176     {
 177         { [ get-char dup CHAR: ! = ] [ drop next direct ] }
 178         { [ dup CHAR: ? = ] [ drop next instruct ] }
 179         { [ dup CHAR: - = ] [ drop next interpolate-tag ] }
 180         [ drop normal-tag ]
 181     } cond ;