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 namespaces sequences strings io.encodings.utf8
   5 xml.data xml.errors xml.elements ascii xml.entities
   6 xml.writer xml.state xml.autoencoding assocs xml.tokenize
   7 combinators.short-circuit xml.name splitting io.streams.byte-array
   8 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 : ?first ( seq -- elt/f ) 0 swap ?nth ;
  87
  88 : get-prolog ( seq -- prolog )
  89     { "" } ?head drop
  90     ?first dup prolog?
  91     [ drop default-prolog ] unless ;
  92
  93 : cut-prolog ( seq -- newseq )
  94     [ [ prolog? not ] [ "" = not ] bi and ] filter ;
  95
  96 : make-xml-doc ( seq -- xml-doc )
  97     [ get-prolog ] keep
  98     dup [ tag? ] find [
  99         assure-tags cut
 100         [ cut-prolog ] [ rest ] bi*
 101         no-pre/post no-post-tags
 102     ] dip swap <xml> ;
 103
 104 ! * Views of XML
 105
 106 SYMBOL: text-now?
 107
 108 PRIVATE>
 109
 110 TUPLE: pull-xml scope ;
 111 : <pull-xml> ( -- pull-xml )
 112     [
 113         init-parser
 114         input-stream [ ] change ! bring var in this scope
 115         init-xml text-now? on
 116     ] H{ } make-assoc
 117     pull-xml boa ;
 118 ! pull-xml needs to call start-document somewhere
 119
 120 : pull-event ( pull -- xml-event/f )
 121     scope>> [
 122         text-now? get [ parse-text f ] [
 123             get-char [ make-tag t ] [ f f ] if
 124         ] if text-now? set
 125     ] bind ;
 126
 127 <PRIVATE
 128
 129 : done? ( -- ? )
 130     xml-stack get length 1 = ;
 131
 132 : (pull-elem) ( pull -- xml-elem/f )
 133     dup pull-event dup closer? done? and [ nip ] [
 134         process done?
 135         [ drop xml-stack get first second ]
 136         [ (pull-elem) ] if
 137     ] if ;
 138
 139 PRIVATE>
 140
 141 : pull-elem ( pull -- xml-elem/f )
 142     [ init-xml-stack (pull-elem) ] with-scope ;
 143
 144 <PRIVATE
 145
 146 : call-under ( quot object -- quot )
 147     swap [ call ] keep ; inline
 148
 149 : xml-loop ( quot: ( xml-elem -- ) -- )
 150     parse-text call-under
 151     get-char [ make-tag call-under xml-loop ]
 152     [ drop ] if ; inline recursive
 153
 154 : read-seq ( stream quot n -- seq )
 155     rot [
 156         depth set
 157         init-xml init-xml-stack
 158         call
 159         [ process ] xml-loop
 160         done? [ unclosed ] unless
 161         xml-stack get first second
 162     ] with-state ; inline
 163
 164 : make-xml ( stream quot -- xml )
 165     0 read-seq make-xml-doc ; inline
 166
 167 PRIVATE>
 168
 169 : each-element ( stream quot: ( xml-elem -- ) -- )
 170     swap [
 171         init-xml
 172         start-document [ call-under ] when*
 173         xml-loop
 174     ] with-state ; inline
 175
 176 : read-xml ( stream -- xml )
 177     dup stream-element-type {
 178         { +character+ [ [ check ] make-xml ] }
 179         { +byte+ [ [ start-document [ process ] when* ] make-xml ] }
 180     } case ;
 181
 182 : read-xml-chunk ( stream -- seq )
 183     [ check ] 1 read-seq <xml-chunk> ;
 184
 185 : string>xml ( string -- xml )
 186     <string-reader> read-xml ;
 187
 188 : string>xml-chunk ( string -- xml )
 189     <string-reader> read-xml-chunk ;
 190
 191 : file>xml ( filename -- xml )
 192     binary <file-reader> read-xml ;
 193
 194 : bytes>xml ( byte-array -- xml )
 195     binary <byte-reader> read-xml ;
 196
 197 : read-dtd ( stream -- dtd )
 198     [
 199         H{ } clone extra-entities set
 200         take-internal-subset
 201     ] with-state ;
 202
 203 : file>dtd ( filename -- dtd )
 204     utf8 <file-reader> read-dtd ;
 205
 206 : string>dtd ( string -- dtd )
 207     <string-reader> read-dtd ;