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