xml.l (9405B)
1 # 13apr11abu 2 # 21jan09 Tomas Hlavaty <kvietaag@seznam.cz> 3 4 # Check or write header 5 (de xml? (Flg) 6 (if Flg 7 (prinl "<?xml version=\"1.0\" encoding=\"utf-8\"?>") 8 (skip) 9 (prog1 10 (head '("<" "?" "x" "m" "l") (till ">")) 11 (char) ) ) ) 12 13 # Generate/Parse XML data 14 # expects well formed XML 15 # encoding by picolisp (utf8 "only", no utf16 etc.) 16 # trim whitespace except in cdata 17 # ignore <? <!-- <!DOCTYPE 18 # non-builtin entities as normal text: &ent; => ent 19 (de xml (Lst N) 20 (if Lst 21 (let (Nn NIL Nl NIL Pre NIL) 22 (when N 23 (do (abs N) 24 (push 'Nn (if (lt0 N) "^I" " ")) ) ) 25 (_xml_ Lst) ) 26 (_xml) ) ) 27 28 (de _xml_ (Lst) 29 (let Tag (pop 'Lst) 30 (when Nl 31 (prinl) 32 (when Pre 33 (prin Pre) ) ) 34 (prin "<" Tag) 35 (for X (pop 'Lst) 36 (prin " " (car X) "=\"") 37 (escXml (cdr X)) 38 (prin "\"") ) 39 (ifn Lst 40 (prin "/>") 41 (prin ">") 42 (use Nlx 43 (let (Nl N 44 Pre (cons Pre Nn) ) 45 (for X Lst 46 (if (pair X) 47 (_xml_ X) 48 (off Nl) 49 (escXml X) ) ) 50 (setq Nlx Nl) ) 51 (when Nlx 52 (prinl) 53 (when Pre 54 (prin Pre) ) ) ) 55 (prin "</" Tag ">") ) ) ) 56 57 (de _xml (In Char) 58 (unless Char 59 (skip) 60 (unless (= "<" (char)) 61 (quit "Bad XML") ) ) 62 (case (peek) 63 ("?" 64 (from "?>") 65 (unless In (_xml In)) ) 66 ("!" 67 (char) 68 (case (peek) 69 ("-" 70 (ifn (= "-" (char) (char)) 71 (quit "XML comment expected") 72 (from "-->") 73 (unless In (_xml In)) ) ) 74 ("D" 75 (if (find '((C) (<> C (char))) '`(chop "DOCTYPE")) 76 (quit "XML DOCTYPE expected") 77 (when (= "[" (from "[" ">")) 78 (use X 79 (loop 80 (T (= "]" (setq X (from "]" "\"" "'" "<!--")))) 81 (case X 82 ("\"" (from "\"")) 83 ("'" (from "'")) 84 ("<!--" (from "-->")) 85 (NIL (quit "Unbalanced XML DOCTYPE")) ) ) ) 86 (from ">") ) 87 (unless In (_xml In)) ) ) 88 ("[" 89 (if (find '((C) (<> C (char))) '`(chop "[CDATA[")) 90 (quit "XML CDATA expected") 91 (pack 92 (head -3 93 (make 94 (loop 95 (NIL (link (char)) (quit "Unbalanced XML CDATA")) 96 (T (= '`(chop "]]>") (tail 3 (made)))) ) ) ) ) ) ) 97 (T (quit "Unhandled XML tag")) ) ) 98 (T 99 (let Tok (till " ^I^M^J/>" T) 100 (use X 101 (make 102 (link (intern (pack Tok))) 103 (let L 104 (make 105 (loop 106 (NIL (skip) (quit "Unexpected end of XML" Tok)) 107 (T (member @ '("/" ">"))) 108 (NIL (setq X (intern (pack (trim (till "=")))))) 109 (char) 110 (skip) 111 (let C (char) 112 (unless (member C '("\"" "'")) 113 (quit "XML attribute quote expected" X) ) 114 (link (cons X (pack (xmlEsc (till C))))) ) 115 (char) ) ) 116 (if (= "/" (char)) 117 (prog (char) (and L (link L))) 118 (link L) 119 (loop 120 (NIL (if *XmlKeepBlanks (peek) (skip)) 121 (quit "Unexpected end of XML" Tok) ) 122 (T (and (= "<" (setq X (char))) (= "/" (peek))) 123 (char) 124 (unless (= Tok (till " ^I^M^J/>" T)) 125 (quit "Unbalanced XML" Tok) ) 126 (skip) 127 (char) ) 128 (if (= "<" X) 129 (when (_xml T "<") 130 (link @) ) 131 (link 132 (pack 133 (xmlEsc 134 ((if *XmlKeepBlanks prog trim) 135 (cons X (till "<")) ) ) ) ) ) ) ) ) ) ) ) ) ) ) 136 137 (de xmlEsc (L) 138 (use (@X @Z) 139 (make 140 (while L 141 (ifn (match '("&" @X ";" @Z) L) 142 (link (pop 'L)) 143 (link 144 (cond 145 ((= @X '`(chop "quot")) "\"") 146 ((= @X '`(chop "amp")) "&") 147 ((= @X '`(chop "lt")) "<") 148 ((= @X '`(chop "gt")) ">") 149 ((= @X '`(chop "apos")) "'") 150 ((= "#" (car @X)) 151 (char 152 (if (= "x" (cadr @X)) 153 (hex (cddr @X)) 154 (format (cdr @X)) ) ) ) 155 (T @X) ) ) 156 (setq L @Z) ) ) ) ) ) 157 158 (de escXml (X) 159 (for C (chop X) 160 (prin (case C 161 ("\"" """) 162 ("&" "&") 163 ("<" "<") 164 (">" ">") 165 (T C) ) ) ) ) 166 167 168 # Simple XML string 169 (de xml$ (Lst) 170 (pack 171 (make 172 (recur (Lst) 173 (let Tag (pop 'Lst) 174 (link "<" Tag) 175 (for X (pop 'Lst) 176 (link " " (car X) "=\"" (cdr X) "\"") ) 177 (ifn Lst 178 (link "/>") 179 (link ">") 180 (for X Lst 181 (if (pair X) 182 (recurse X (+ 3 N)) 183 (link X) ) ) 184 (link "</" Tag ">") ) ) ) ) ) ) 185 186 187 # Access functions 188 (de body (Lst . @) 189 (while (and (setq Lst (cddr Lst)) (args)) 190 (setq Lst (assoc (next) Lst)) ) 191 Lst ) 192 193 (de attr (Lst Key . @) 194 (while (args) 195 (setq 196 Lst (assoc Key (cddr Lst)) 197 Key (next) ) ) 198 (cdr (assoc Key (cadr Lst))) ) 199 200 # <xml> output 201 (de "xmlL" Lst 202 (push '"Xml" 203 (make 204 (link (pop 'Lst)) 205 (let Att (make 206 (while (and Lst (car Lst) (atom (car Lst))) 207 (let K (pop 'Lst) 208 (if (=T K) 209 (for X (eval (pop 'Lst) 1) 210 (if (=T (car X)) 211 (link (cons (cdr X) NIL)) 212 (when (cdr X) 213 (link X) ) ) ) 214 (when (eval (pop 'Lst) 1) 215 (link (cons K @)) ) ) ) ) ) 216 (let "Xml" NIL 217 (xrun Lst) 218 (ifn "Xml" 219 (when Att 220 (link Att) ) 221 (link Att) 222 (chain (flip "Xml")) ) ) ) ) ) ) 223 224 (de "xmlO" Lst 225 (let Tag (pop 'Lst) 226 (when "Nl" 227 (prinl) 228 (when "Pre" 229 (prin "Pre") ) ) 230 (prin "<" Tag) 231 (while (and Lst (car Lst) (atom (car Lst))) 232 (let K (pop 'Lst) 233 (if (=T K) 234 (for X (eval (pop 'Lst) 1) 235 (if (=T (car X)) 236 (prin " " (cdr X) "=\"\"") 237 (when (cdr X) 238 (prin " " (car X) "=\"") 239 (escXml (cdr X)) 240 (prin "\"") ) ) ) 241 (when (eval (pop 'Lst) 1) 242 (prin " " K "=\"") 243 (escXml @) 244 (prin "\"") ) ) ) ) 245 (ifn Lst 246 (prin "/>") 247 (prin ">") 248 (use Nl 249 (let ("Nl" "N" 250 "Pre" (cons "Pre" "Nn") ) 251 (xrun Lst) 252 (setq Nl "Nl") ) 253 (when Nl 254 (prinl) 255 (when "Pre" 256 (prin "Pre") ) ) ) 257 (prin "</" Tag ">") ) ) ) 258 259 (de <xml> ("N" . Lst) 260 (if (=T "N") 261 (let (<xml> "xmlL" 262 xprin '(@ (push '"Xml" (pass pack))) 263 xrun '((Lst Ofs) 264 (default Ofs 2) 265 (for X Lst 266 (if (pair X) 267 (eval X Ofs '("Xml")) 268 (when (eval X Ofs '("Xml")) 269 (xprin @) ) ) ) ) 270 "Xml" NIL ) 271 (run Lst 1 '(<xml> xprin xrun "Xml")) 272 (car (flip "Xml")) ) 273 (let (<xml> "xmlO" 274 xprin '(@ (off "Nl") (mapc escXml (rest))) 275 xrun '((Lst Ofs) 276 (default Ofs 2) 277 (for X Lst 278 (if (pair X) 279 (eval X Ofs '("Nl" "Pre")) 280 (when (eval X Ofs '("Nl" "Pre")) 281 (xprin @) ) ) ) ) 282 "Nn" NIL 283 "Nl" NIL 284 "Pre" NIL ) 285 (when "N" 286 (do (abs "N") 287 (push '"Nn" (if (lt0 "N") "^I" " ")) ) ) 288 (run Lst 1 '(<xml> xprin xrun "N" "Nn" "Nl" "Pre")) ) ) ) 289 290 # vi:et:ts=3:sw=3