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