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         input-stream [ ] change ! bring var in this scope
 114         init-xml text-now? on
 115     ] H{ } make-assoc
 116     pull-xml boa ;
 117 ! pull-xml needs to call start-document somewhere
 118
 119 : pull-event ( pull -- xml-event/f )
 120     scope>> [
 121         text-now? get [ parse-text f ] [
 122             get-char [ make-tag t ] [ f f ] if
 123         ] if text-now? set
 124     ] bind ;
 125
 126 <PRIVATE
 127
 128 : done? ( -- ? )
 129     xml-stack get length 1 = ;
 130
 131 : (pull-elem) ( pull -- xml-elem/f )
 132     dup pull-event dup closer? done? and [ nip ] [
 133         process done?
 134         [ drop xml-stack get first second ]
 135         [ (pull-elem) ] if
 136     ] if ;
 137
 138 PRIVATE>
 139
 140 : pull-elem ( pull -- xml-elem/f )
 141     [ init-xml-stack (pull-elem) ] with-scope ;
 142
 143 <PRIVATE
 144
 145 : call-under ( quot object -- quot )
 146     swap [ call ] keep ; inline
 147
 148 : xml-loop ( quot: ( xml-elem -- ) -- )
 149     parse-text call-under
 150     get-char [ make-tag call-under xml-loop ]
 151     [ drop ] if ; inline recursive
 152
 153 : read-seq ( stream quot n -- seq )
 154     rot [
 155         depth set
 156         init-xml init-xml-stack
 157         call
 158         [ process ] xml-loop
 159         done? [ unclosed ] unless
 160         xml-stack get first second
 161     ] with-state ; inline
 162
 163 : make-xml ( stream quot -- xml )
 164     0 read-seq make-xml-doc ; inline
 165
 166 PRIVATE>
 167
 168 : each-element ( stream quot: ( xml-elem -- ) -- )
 169     swap [
 170         init-xml
 171         start-document [ call-under ] when*
 172         xml-loop
 173     ] with-state ; inline
 174
 175 : read-xml ( stream -- xml )
 176     dup stream-element-type {
 177         { +character+ [ [ check ] make-xml ] }
 178         { +byte+ [ [ start-document [ process ] when* ] make-xml ] }
 179     } case ;
 180
 181 : read-xml-chunk ( stream -- seq )
 182     [ check ] 1 read-seq <xml-chunk> ;
 183
 184 : string>xml ( string -- xml )
 185     <string-reader> read-xml ;
 186
 187 : string>xml-chunk ( string -- xml )
 188     <string-reader> read-xml-chunk ;
 189
 190 : file>xml ( filename -- xml )
 191     binary <file-reader> read-xml ;
 192
 193 : bytes>xml ( byte-array -- xml )
 194     binary <byte-reader> read-xml ;
 195
 196 : read-dtd ( stream -- dtd )
 197     [
 198         H{ } clone extra-entities set
 199         take-internal-subset
 200     ] with-state ;
 201
 202 : file>dtd ( filename -- dtd )
 203     utf8 <file-reader> read-dtd ;
 204
 205 : string>dtd ( string -- dtd )
 206     <string-reader> read-dtd ;