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> throw ] unless drop ;
  28
  29 M: instruction process
  30     xml-stack get length 1 =
  31     [ <bad-instruction> throw ] 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     [ <bad-directive> throw ] unless
  38     add-child ;
  39
  40 M: contained process
  41     [ contained-name ] keep contained-attrs
  42     <contained-tag> add-child ;
  43
  44 M: opener process push-xml ;
  45
  46 : check-closer ( name opener -- name opener )
  47     dup [ <unopened> throw ] unless
  48     2dup opener-name =
  49     [ opener-name swap <mismatched> throw ] unless ;
  50
  51 M: closer process
  52     closer-name pop-xml first2
  53     >r check-closer opener-attrs r>
  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> throw ] if
  73     ] each drop ;
  74
  75 : no-pre/post ( pre post -- pre post/* )
  76     ! this does *not* affect the contents of the stack
  77     >r dup t assert-blanks r>
  78     dup f assert-blanks ;
  79
  80 : no-post-tags ( post -- post/* )
  81     ! this does *not* affect the contents of the stack
  82     dup [ tag? ] contains? [ <multitags> throw ] when ;
  83
  84 : assure-tags ( seq -- seq )
  85     ! this does *not* affect the contents of the stack
  86     [ <notags> throw ] unless* ;
  87
  88 : make-xml-doc ( prolog seq -- xml-doc )
  89     dup [ tag? ] find
  90     >r assure-tags cut rest
  91     no-pre/post no-post-tags
  92     r> swap <xml> ;
  93
  94 ! * Views of XML
  95
  96 SYMBOL: text-now?
  97
  98 TUPLE: pull-xml scope ;
  99 : <pull-xml> ( -- pull-xml )
 100     [
 101         input-stream [ ] change ! bring var in this scope
 102         init-parser reset-prolog init-ns-stack
 103         text-now? on
 104     ] H{ } make-assoc
 105     { set-pull-xml-scope } pull-xml construct ;
 106
 107 : pull-event ( pull -- xml-event/f )
 108     pull-xml-scope [
 109         text-now? get [ parse-text f ] [
 110             get-char [ make-tag t ] [ f f ] if
 111         ] if text-now? set
 112     ] bind ;
 113
 114 : done? ( -- ? )
 115     xml-stack get length 1 = ;
 116
 117 : (pull-elem) ( pull -- xml-elem/f )
 118     dup pull-event dup closer? done? and [ nip ] [
 119         process done?
 120         [ drop xml-stack get first second ]
 121         [ (pull-elem) ] if
 122     ] if ;
 123
 124 : pull-elem ( pull -- xml-elem/f )
 125     [ init-xml-stack (pull-elem) ] with-scope ;
 126
 127 : call-under ( quot object -- quot )
 128     swap dup slip ; inline
 129
 130 : sax-loop ( quot -- ) ! quot: xml-elem --
 131     parse-text call-under
 132     get-char [ make-tag call-under sax-loop ]
 133     [ drop ] if ; inline
 134
 135 : sax ( stream quot -- ) ! quot: xml-elem --
 136     swap [
 137         reset-prolog init-ns-stack
 138         prolog-data get call-under
 139         sax-loop
 140     ] state-parse ; inline
 141
 142 : (read-xml) ( -- )
 143     [ process ] sax-loop ; inline
 144
 145 : (xml-chunk) ( stream -- prolog seq )
 146     [
 147         init-xml (read-xml)
 148         done? [ <unclosed> throw ] unless
 149         xml-stack get first second
 150         prolog-data get swap
 151     ] state-parse ;
 152
 153 : read-xml ( stream -- xml )
 154     #! Produces a tree of XML nodes
 155     (xml-chunk) make-xml-doc ;
 156
 157 : xml-chunk ( stream -- seq )
 158     (xml-chunk) nip ;
 159
 160 : string>xml ( string -- xml )
 161     <string-reader> read-xml ;
 162
 163 : file>xml ( filename -- xml )
 164     ! Autodetect encoding!
 165     utf8 <file-reader> read-xml ;
 166
 167 : xml-reprint ( string -- )
 168     string>xml print-xml ;
 169