basis/xml/xml.factor

   1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays io io.encodings.binary io.files
   4 io.streams.string kernel math namespaces sequences strings
   5 io.encodings.utf8 xml.data xml.errors xml.elements ascii
   6 xml.entities xml.state xml.autoencoding assocs xml.tokenize
   7 combinators.short-circuit xml.name splitting
   8 io.streams.byte-array combinators ;
   9 IN: xml
  10
  11 <PRIVATE
  12
  13 : add-child ( object -- )
  14     xml-stack get last second push ;
  15
  16 : push-xml ( object -- )
  17     V{ } clone 2array xml-stack get push ;
  18
  19 : pop-xml ( -- object )
  20     xml-stack get pop ;
  21
  22 GENERIC: process ( object -- )
  23
  24 M: object process add-child ;
  25
  26 M: prolog process
  27     xml-stack get
  28     { V{ { f V{ "" } } } V{ { f V{ } } } } member?
  29     [ bad-prolog ] unless add-child ;
  30
  31 : before-main? ( -- ? )
  32     xml-stack get {
  33         [ length 1 = ]
  34         [ first second [ tag? ] any? not ]
  35     } 1&& ;
  36
  37 M: directive process
  38     before-main? [ misplaced-directive ] unless add-child ;
  39
  40 M: contained process
  41     [ name>> ] [ attrs>> ] bi
  42     <contained-tag> add-child ;
  43
  44 M: opener process push-xml ;
  45
  46 : check-closer ( name opener -- name opener )
  47     dup [ unopened ] unless
  48     2dup name>> =
  49     [ name>> swap mismatched ] unless ;
  50
  51 M: closer process
  52     name>> pop-xml first2
  53     [ check-closer attrs>> ] dip
  54     <tag> add-child ;
  55
  56 : init-xml-stack ( -- )
  57     V{ } clone xml-stack set
  58     f push-xml ;
  59
  60 : default-prolog ( -- prolog )
  61     "1.0" "UTF-8" f <prolog> ;
  62
  63 : init-xml ( -- )
  64     init-ns-stack
  65     extra-entities [ H{ } assoc-like ] change ;
  66
  67 : assert-blanks ( seq pre? -- )
  68     swap [ string? ] filter
  69     [
  70         dup [ blank? ] all?
  71         [ drop ] [ swap pre/post-content ] if
  72     ] each drop ;
  73
  74 : no-pre/post ( pre post -- pre post/* )
  75     ! this does *not* affect the contents of the stack
  76     [ dup t assert-blanks ] [ dup f assert-blanks ] bi* ;
  77
  78 : no-post-tags ( post -- post/* )
  79     ! this does *not* affect the contents of the stack
  80     dup [ tag? ] any? [ multitags ] when ;
  81
  82 : assure-tags ( seq -- seq )
  83     ! this does *not* affect the contents of the stack
  84     [ notags ] unless* ;
  85
  86 : get-prolog ( seq -- prolog )
  87     { "" } ?head drop
  88     ?first dup prolog?
  89     [ drop default-prolog ] unless ;
  90
  91 : cut-prolog ( seq -- newseq )
  92     [ { [ prolog? not ] [ "" = not ] } 1&& ] filter ;
  93
  94 : make-xml-doc ( seq -- xml-doc )
  95     [ get-prolog ] keep
  96     dup [ tag? ] find [
  97         assure-tags cut
  98         [ cut-prolog ] [ rest ] bi*
  99         no-pre/post no-post-tags
 100     ] dip swap <xml> ;
 101
 102 ! * Views of XML
 103
 104 SYMBOL: text-now?
 105
 106 : collect-variables ( -- hash )
 107     {
 108         input-stream
 109         extra-entities
 110         spot
 111         ns-stack
 112         text-now?
 113     } [ dup get ] H{ } map>assoc ;
 114
 115 PRIVATE>
 116
 117 TUPLE: pull-xml scope ;
 118 : <pull-xml> ( -- pull-xml )
 119     [
 120         init-parser init-xml text-now? on collect-variables
 121     ] with-scope pull-xml boa ;
 122 ! pull-xml needs to call start-document somewhere
 123
 124 : pull-event ( pull -- xml-event/f )
 125     scope>> [
 126         text-now? get [ parse-text f ] [
 127             get-char [ make-tag t ] [ f f ] if
 128         ] if text-now? set
 129     ] with-variables ;
 130
 131 <PRIVATE
 132
 133 : done? ( -- ? )
 134     xml-stack get length 1 = ;
 135
 136 : (pull-elem) ( pull -- xml-elem/f )
 137     dup pull-event dup closer? done? and [ nip ] [
 138         process done?
 139         [ drop xml-stack get first second ]
 140         [ (pull-elem) ] if
 141     ] if ;
 142
 143 PRIVATE>
 144
 145 : pull-elem ( pull -- xml-elem/f )
 146     [ init-xml-stack (pull-elem) ] with-scope ;
 147
 148 <PRIVATE
 149
 150 : call-under ( quot object -- quot )
 151     swap [ call ] keep ; inline
 152
 153 : xml-loop ( quot: ( xml-elem -- ) -- )
 154     parse-text call-under get-char
 155     [ make-tag call-under xml-loop ]
 156     [ drop ] if ; inline recursive
 157
 158 : read-seq ( stream quot n -- seq )
 159     rot [
 160         depth set
 161         init-xml init-xml-stack
 162         call
 163         [ process ] xml-loop
 164         done? [ throw-unclosed ] unless
 165         xml-stack get first second
 166     ] with-state ; inline
 167
 168 : make-xml ( stream quot -- xml )
 169     0 read-seq make-xml-doc ; inline
 170
 171 PRIVATE>
 172
 173 : each-element ( stream quot: ( xml-elem -- ) -- )
 174     swap [
 175         init-xml
 176         start-document [ call-under ] when*
 177         xml-loop
 178     ] with-state ; inline
 179
 180 : read-xml ( stream -- xml )
 181     dup stream-element-type {
 182         { +character+ [ [ check ] make-xml ] }
 183         { +byte+ [ [ start-document [ process ] when* ] make-xml ] }
 184     } case ;
 185
 186 : read-xml-chunk ( stream -- seq )
 187     [ check ] 1 read-seq <xml-chunk> ;
 188
 189 : string>xml ( string -- xml )
 190     <string-reader> read-xml ;
 191
 192 : string>xml-chunk ( string -- xml )
 193     <string-reader> read-xml-chunk ;
 194
 195 : file>xml ( filename -- xml )
 196     binary <file-reader> read-xml ;
 197
 198 : bytes>xml ( byte-array -- xml )
 199     binary <byte-reader> read-xml ;
 200
 201 : read-dtd ( stream -- dtd )
 202     [
 203         H{ } clone extra-entities set
 204         take-internal-subset
 205     ] with-state ;
 206
 207 : file>dtd ( filename -- dtd )
 208     utf8 <file-reader> read-dtd ;
 209
 210 : string>dtd ( string -- dtd )
 211     <string-reader> read-dtd ;