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