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 ;
   8 IN: xml
   9
  10 <PRIVATE
  11
  12 : add-child ( object -- )
  13     xml-stack get peek second push ;
  14
  15 : push-xml ( object -- )
  16     V{ } clone 2array xml-stack get push ;
  17
  18 : pop-xml ( -- object )
  19     xml-stack get pop ;
  20
  21 GENERIC: process ( object -- )
  22
  23 M: object process add-child ;
  24
  25 M: prolog process
  26     xml-stack get
  27     { V{ { f V{ "" } } } V{ { f V{ } } } } member?
  28     [ bad-prolog ] unless drop ;
  29
  30 : before-main? ( -- ? )
  31     xml-stack get {
  32         [ length 1 = ]
  33         [ first second [ tag? ] contains? not ]
  34     } 1&& ;
  35
  36 M: directive process
  37     before-main? [ misplaced-directive ] unless add-child ;
  38
  39 M: contained process
  40     [ name>> ] [ attrs>> ] bi
  41     <contained-tag> add-child ;
  42
  43 M: opener process push-xml ;
  44
  45 : check-closer ( name opener -- name opener )
  46     dup [ unopened ] unless
  47     2dup name>> =
  48     [ name>> swap mismatched ] unless ;
  49
  50 M: closer process
  51     name>> pop-xml first2
  52     [ check-closer attrs>> ] dip
  53     <tag> add-child ;
  54
  55 : init-xml-stack ( -- )
  56     V{ } clone xml-stack set
  57     f push-xml ;
  58
  59 : default-prolog ( -- prolog )
  60     "1.0" "UTF-8" f <prolog> ;
  61
  62 : init-xml ( -- )
  63     init-ns-stack
  64     extra-entities [ H{ } assoc-like ] change ;
  65
  66 : assert-blanks ( seq pre? -- )
  67     swap [ string? ] filter
  68     [
  69         dup [ blank? ] all?
  70         [ drop ] [ swap pre/post-content ] if
  71     ] each drop ;
  72
  73 : no-pre/post ( pre post -- pre post/* )
  74     ! this does *not* affect the contents of the stack
  75     [ dup t assert-blanks ] [ dup f assert-blanks ] bi* ;
  76
  77 : no-post-tags ( post -- post/* )
  78     ! this does *not* affect the contents of the stack
  79     dup [ tag? ] contains? [ multitags ] when ;
  80
  81 : assure-tags ( seq -- seq )
  82     ! this does *not* affect the contents of the stack
  83     [ notags ] unless* ;
  84
  85 : get-prolog ( seq -- prolog )
  86     first dup prolog? [ drop default-prolog ] unless ;
  87
  88 : make-xml-doc ( seq -- xml-doc )
  89     [ get-prolog ] keep
  90     dup [ tag? ] find
  91     [ assure-tags cut rest no-pre/post no-post-tags ] dip
  92     swap <xml> ;
  93
  94 ! * Views of XML
  95
  96 SYMBOL: text-now?
  97
  98 PRIVATE>
  99
 100 TUPLE: pull-xml scope ;
 101 : <pull-xml> ( -- pull-xml )
 102     [
 103         input-stream [ ] change ! bring var in this scope
 104         init-xml text-now? on
 105     ] H{ } make-assoc
 106     pull-xml boa ;
 107 ! pull-xml needs to call start-document somewhere
 108
 109 : pull-event ( pull -- xml-event/f )
 110     scope>> [
 111         text-now? get [ parse-text f ] [
 112             get-char [ make-tag t ] [ f f ] if
 113         ] if text-now? set
 114     ] bind ;
 115
 116 <PRIVATE
 117
 118 : done? ( -- ? )
 119     xml-stack get length 1 = ;
 120
 121 : (pull-elem) ( pull -- xml-elem/f )
 122     dup pull-event dup closer? done? and [ nip ] [
 123         process done?
 124         [ drop xml-stack get first second ]
 125         [ (pull-elem) ] if
 126     ] if ;
 127
 128 PRIVATE>
 129
 130 : pull-elem ( pull -- xml-elem/f )
 131     [ init-xml-stack (pull-elem) ] with-scope ;
 132
 133 <PRIVATE
 134
 135 : call-under ( quot object -- quot )
 136     swap dup slip ; inline
 137
 138 : xml-loop ( quot: ( xml-elem -- ) -- )
 139     parse-text call-under
 140     get-char [ make-tag call-under xml-loop ]
 141     [ drop ] if ; inline recursive
 142
 143 : read-seq ( stream quot n -- seq )
 144     rot [
 145         depth set
 146         init-xml init-xml-stack
 147         call
 148         [ process ] xml-loop
 149         done? [ unclosed ] unless
 150         xml-stack get first second
 151     ] with-state ; inline
 152
 153 PRIVATE>
 154
 155 : each-element ( stream quot: ( xml-elem -- ) -- )
 156     swap [
 157         init-xml
 158         start-document [ call-under ] when*
 159         xml-loop
 160     ] with-state ; inline
 161
 162 : read-xml ( stream -- xml )
 163     [ start-document [ process ] when* ]
 164     0 read-seq make-xml-doc ;
 165
 166 : read-xml-chunk ( stream -- seq )
 167     [ check ] 1 read-seq <xml-chunk> ;
 168
 169 : string>xml ( string -- xml )
 170     <string-reader> [ check ] 0 read-seq make-xml-doc ;
 171
 172 : string>xml-chunk ( string -- xml )
 173     <string-reader> read-xml-chunk ;
 174
 175 : file>xml ( filename -- xml )
 176     binary <file-reader> read-xml ;
 177
 178 : read-dtd ( stream -- dtd )
 179     [
 180         H{ } clone extra-entities set
 181         take-internal-subset
 182     ] with-state ;
 183
 184 : file>dtd ( filename -- dtd )
 185     utf8 <file-reader> read-dtd ;
 186
 187 : string>dtd ( string -- dtd )
 188     <string-reader> read-dtd ;