basis/xml/xml.factor

   1 ! Copyright (C) 2005, 2006 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: io io.streams.string io.files kernel math namespaces
   4 prettyprint sequences arrays generic strings vectors
   5 xml.char-classes xml.data xml.errors xml.tokenize xml.writer
   6 xml.utilities state-parser assocs ascii io.encodings.utf8
   7 accessors xml.backend ;
   8 IN: xml
   9
  10 !   -- Overall parser with data tree
  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 V{ { f V{ "" } } } =
  27     [ bad-prolog ] unless drop ;
  28
  29 M: instruction process
  30     xml-stack get length 1 =
  31     [ bad-instruction ] unless
  32     add-child ;
  33
  34 M: directive process
  35     xml-stack get dup length 1 =
  36     swap first second [ tag? ] contains? not and
  37     [ misplaced-directive ] unless
  38     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 f push-xml ;
  58
  59 : default-prolog ( -- prolog )
  60     "1.0" "UTF-8" f <prolog> ;
  61
  62 : reset-prolog ( -- )
  63     default-prolog prolog-data set ;
  64
  65 : init-xml ( -- )
  66     reset-prolog init-xml-stack init-ns-stack ;
  67
  68 : assert-blanks ( seq pre? -- )
  69     swap [ string? ] filter
  70     [
  71         dup [ blank? ] all?
  72         [ drop ] [ swap pre/post-content ] if
  73     ] each drop ;
  74
  75 : no-pre/post ( pre post -- pre post/* )
  76     ! this does *not* affect the contents of the stack
  77     [ dup t assert-blanks ] [ dup f assert-blanks ] bi* ;
  78
  79 : no-post-tags ( post -- post/* )
  80     ! this does *not* affect the contents of the stack
  81     dup [ tag? ] contains? [ multitags ] when ;
  82
  83 : assure-tags ( seq -- seq )
  84     ! this does *not* affect the contents of the stack
  85     [ notags ] unless* ;
  86
  87 : make-xml-doc ( prolog seq -- xml-doc )
  88     dup [ tag? ] find
  89     [ assure-tags cut rest no-pre/post no-post-tags ] dip
  90     swap <xml> ;
  91
  92 ! * Views of XML
  93
  94 SYMBOL: text-now?
  95
  96 TUPLE: pull-xml scope ;
  97 : <pull-xml> ( -- pull-xml )
  98     [
  99         input-stream [ ] change ! bring var in this scope
 100         init-parser reset-prolog init-ns-stack
 101         text-now? on
 102     ] H{ } make-assoc
 103     pull-xml boa ;
 104
 105 : pull-event ( pull -- xml-event/f )
 106     scope>> [
 107         text-now? get [ parse-text f ] [
 108             get-char [ make-tag t ] [ f f ] if
 109         ] if text-now? set
 110     ] bind ;
 111
 112 : done? ( -- ? )
 113     xml-stack get length 1 = ;
 114
 115 : (pull-elem) ( pull -- xml-elem/f )
 116     dup pull-event dup closer? done? and [ nip ] [
 117         process done?
 118         [ drop xml-stack get first second ]
 119         [ (pull-elem) ] if
 120     ] if ;
 121
 122 : pull-elem ( pull -- xml-elem/f )
 123     [ init-xml-stack (pull-elem) ] with-scope ;
 124
 125 : call-under ( quot object -- quot )
 126     swap dup slip ; inline
 127
 128 : sax-loop ( quot: ( xml-elem -- ) -- )
 129     parse-text call-under
 130     get-char [ make-tag call-under sax-loop ]
 131     [ drop ] if ; inline recursive
 132
 133 : sax ( stream quot: ( xml-elem -- ) -- )
 134     swap [
 135         reset-prolog init-ns-stack
 136         prolog-data get call-under
 137         sax-loop
 138     ] state-parse ; inline recursive
 139
 140 : (read-xml) ( -- )
 141     [ process ] sax-loop ; inline
 142
 143 : (read-xml-chunk) ( stream -- prolog seq )
 144     [
 145         init-xml (read-xml)
 146         done? [ unclosed ] unless
 147         xml-stack get first second
 148         prolog-data get swap
 149     ] state-parse ;
 150
 151 : read-xml ( stream -- xml )
 152     #! Produces a tree of XML nodes
 153     (read-xml-chunk) make-xml-doc ;
 154
 155 : read-xml-chunk ( stream -- seq )
 156     (read-xml-chunk) nip ;
 157
 158 : string>xml ( string -- xml )
 159     <string-reader> read-xml ;
 160
 161 : string>xml-chunk ( string -- xml )
 162     <string-reader> read-xml-chunk ;
 163
 164 : file>xml ( filename -- xml )
 165     ! Autodetect encoding!
 166     utf8 <file-reader> read-xml ;
 167
 168 : xml-reprint ( string -- )
 169     string>xml print-xml ;
 170