xm.l (3358B)
1 # 17nov10abu 2 # (c) Software Lab. Alexander Burger 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 (de xml (Lst N) 15 (if Lst 16 (let Tag (pop 'Lst) 17 (space (default N 0)) 18 (prin "<" Tag) 19 (for X (pop 'Lst) 20 (prin " " (car X) "=\"") 21 (escXml (cdr X)) 22 (prin "\"") ) 23 (nond 24 (Lst (prinl "/>")) 25 ((or (cdr Lst) (pair (car Lst))) 26 (prin ">") 27 (escXml (car Lst)) 28 (prinl "</" Tag ">") ) 29 (NIL 30 (prinl ">") 31 (for X Lst 32 (if (pair X) 33 (xml X (+ 3 N)) 34 (space (+ 3 N)) 35 (escXml X) 36 (prinl) ) ) 37 (space N) 38 (prinl "</" Tag ">") ) ) ) 39 (skip) 40 (unless (= "<" (char)) 41 (quit "Bad XML") ) 42 (_xml (till " /<>" T)) ) ) 43 44 (de _xml (Tok) 45 (use X 46 (make 47 (link (intern Tok)) 48 (let L 49 (make 50 (loop 51 (NIL (skip) (quit "XML parse error")) 52 (T (member @ '`(chop "/>"))) 53 (NIL (setq X (intern (till "=" T)))) 54 (char) 55 (unless (= "\"" (char)) 56 (quit "XML parse error" X) ) 57 (link (cons X (pack (xmlEsc (till "\""))))) 58 (char) ) ) 59 (if (= "/" (char)) 60 (prog (char) (and L (link L))) 61 (link L) 62 (loop 63 (NIL (skip) (quit "XML parse error" Tok)) 64 (T (and (= "<" (setq X (char))) (= "/" (peek))) 65 (char) 66 (unless (= Tok (till " /<>" T)) 67 (quit "Unbalanced XML" Tok) ) 68 (char) ) 69 (if (= "<" X) 70 (and (_xml (till " /<>" T)) (link @)) 71 (link 72 (pack (xmlEsc (trim (cons X (till "^J<"))))) ) ) ) ) ) ) ) ) 73 74 (de xmlEsc (L) 75 (use (@X @Z) 76 (make 77 (while L 78 (ifn (match '("&" @X ";" @Z) L) 79 (link (pop 'L)) 80 (link 81 (cond 82 ((= @X '`(chop "quot")) "\"") 83 ((= @X '`(chop "amp")) "&") 84 ((= @X '`(chop "lt")) "<") 85 ((= @X '`(chop "gt")) ">") 86 ((= @X '`(chop "apos")) "'") 87 ((= "#" (car @X)) 88 (char 89 (if (= "x" (cadr @X)) 90 (hex (cddr @X)) 91 (format (cdr @X)) ) ) ) 92 (T @X) ) ) 93 (setq L @Z) ) ) ) ) ) 94 95 (de escXml (X) 96 (for C (chop X) 97 (if (member C '`(chop "\"&<")) 98 (prin "&#" (char C) ";") 99 (prin C) ) ) ) 100 101 102 # Access functions 103 (de body (Lst . @) 104 (while (and (setq Lst (cddr Lst)) (args)) 105 (setq Lst (assoc (next) Lst)) ) 106 Lst ) 107 108 (de attr (Lst Key . @) 109 (while (args) 110 (setq 111 Lst (assoc Key (cddr Lst)) 112 Key (next) ) ) 113 (cdr (assoc Key (cadr Lst))) ) 114 115 # vi:et:ts=3:sw=3