AtlatestRepositorysigil-sxml

sigil-sxml / tree / testtest-xml-reader.sgl

1(import (sigil test)
2 (sigil sxml reader))
3
4;; ============================================================
5;; Low-level XML Parser
6;; ============================================================
7
8(test-group "xml-parser"
9 (test "simple element"
10 (let ((p (make-xml-parser)))
11 (xml-parser-feed! p "<hello/>")
12 (let ((events (xml-parser-events! p)))
13 (assert-equal 2 (length events))
14 (assert-equal '(open-tag hello ()) (car events))
15 (assert-equal '(close-tag hello) (cadr events)))))
17 (test "element with text"
18 (let ((p (make-xml-parser)))
19 (xml-parser-feed! p "<p>Hello</p>")
20 (let ((events (xml-parser-events! p)))
21 (assert-equal 3 (length events))
22 (assert-equal '(open-tag p ()) (car events))
23 (assert-equal '(text "Hello") (cadr events))
24 (assert-equal '(close-tag p) (caddr events)))))
26 (test "element with attributes"
27 (let ((p (make-xml-parser)))
28 (xml-parser-feed! p "<div class=\"main\" id=\"content\">text</div>")
29 (let ((events (xml-parser-events! p)))
30 (assert-equal '(open-tag div ((class "main") (id "content")))
31 (car events)))))
33 (test "single-quoted attributes"
34 (let ((p (make-xml-parser)))
35 (xml-parser-feed! p "<a href='http://example.com'>link</a>")
36 (let ((events (xml-parser-events! p)))
37 (assert-equal '(open-tag a ((href "http://example.com")))
38 (car events)))))
40 (test "nested elements"
41 (let ((p (make-xml-parser)))
42 (xml-parser-feed! p "<a><b><c/></b></a>")
43 (let ((events (xml-parser-events! p)))
44 (assert-equal 6 (length events))
45 (assert-equal '(open-tag a ()) (list-ref events 0))
46 (assert-equal '(open-tag b ()) (list-ref events 1))
47 (assert-equal '(open-tag c ()) (list-ref events 2))
48 (assert-equal '(close-tag c) (list-ref events 3))
49 (assert-equal '(close-tag b) (list-ref events 4))
50 (assert-equal '(close-tag a) (list-ref events 5)))))
52 (test "text entities"
53 (let ((p (make-xml-parser)))
54 (xml-parser-feed! p "<p>a &amp; b &lt; c</p>")
55 (let ((events (xml-parser-events! p)))
56 (assert-equal '(text "a & b < c") (cadr events)))))
58 (test "attribute entities"
59 (let ((p (make-xml-parser)))
60 (xml-parser-feed! p "<a title=\"a &amp; b\"/>")
61 (let ((events (xml-parser-events! p)))
62 (assert-equal '(open-tag a ((title "a & b")))
63 (car events)))))
65 (test "incremental feeding"
66 (let ((p (make-xml-parser)))
67 (xml-parser-feed! p "<mes")
68 (xml-parser-feed! p "sage to=\"user@")
69 (xml-parser-feed! p "ex.com\">Hi</mes")
70 (xml-parser-feed! p "sage>")
71 (let ((events (xml-parser-events! p)))
72 (assert-equal 3 (length events))
73 (assert-equal '(open-tag message ((to "[email protected]")))
74 (car events))
75 (assert-equal '(text "Hi") (cadr events))
76 (assert-equal '(close-tag message) (caddr events)))))
78 (test "XML declaration is skipped"
79 (let ((p (make-xml-parser)))
80 (xml-parser-feed! p "<?xml version=\"1.0\"?><root/>")
81 (let ((events (xml-parser-events! p)))
82 (assert-equal 2 (length events))
83 (assert-equal '(open-tag root ()) (car events)))))
85 (test "comment is skipped"
86 (let ((p (make-xml-parser)))
87 (xml-parser-feed! p "<a><!-- comment --><b/></a>")
88 (let ((events (xml-parser-events! p)))
89 (assert-equal 4 (length events))
90 (assert-equal '(open-tag a ()) (car events))
91 (assert-equal '(open-tag b ()) (cadr events)))))
93 (test "namespaced elements"
94 (let ((p (make-xml-parser)))
95 (xml-parser-feed! p "<stream:features><starttls xmlns=\"urn:ietf:params:xml:ns:xmpp-tls\"/></stream:features>")
96 (let ((events (xml-parser-events! p)))
97 (assert-equal '(open-tag stream:features ()) (car events))
98 (assert-equal '(open-tag starttls ((xmlns "urn:ietf:params:xml:ns:xmpp-tls")))
99 (cadr events))))))
101;; ============================================================
102;; Stanza Reader
103;; ============================================================
105(test-group "stanza-reader"
106 (test "stream opener captures attributes"
107 (let ((r (make-stanza-reader)))
108 (stanza-reader-feed! r "<stream:stream xmlns='jabber:client' to='example.com'>")
109 (let ((attrs (stanza-reader-stream-attrs r)))
110 (assert-true (list? attrs))
111 (assert-equal "jabber:client"
112 (cadr (assq 'xmlns attrs)))
113 (assert-equal "example.com"
114 (cadr (assq 'to attrs))))))
116 (test "simple stanza"
117 (let ((r (make-stanza-reader)))
118 (stanza-reader-feed! r "<stream:stream>")
119 (stanza-reader-feed! r "<message><body>Hello</body></message>")
120 (let ((stanzas (stanza-reader-stanzas! r)))
121 (assert-equal 1 (length stanzas))
122 (assert-equal '(message (body "Hello")) (car stanzas)))))
124 (test "stanza with attributes"
125 (let ((r (make-stanza-reader)))
126 (stanza-reader-feed! r "<stream:stream>")
127 (stanza-reader-feed! r "<message to=\"[email protected]\" type=\"chat\"><body>Hi</body></message>")
128 (let ((stanzas (stanza-reader-stanzas! r)))
129 (assert-equal 1 (length stanzas))
130 (let ((msg (car stanzas)))
131 (assert-equal 'message (car msg))
132 ;; Should have attributes
133 (assert-equal '@ (caadr msg))))))
135 (test "multiple stanzas"
136 (let ((r (make-stanza-reader)))
137 (stanza-reader-feed! r "<stream:stream>")
138 (stanza-reader-feed! r "<a/><b>text</b><c><d/></c>")
139 (let ((stanzas (stanza-reader-stanzas! r)))
140 (assert-equal 3 (length stanzas))
141 (assert-equal '(a) (car stanzas))
142 (assert-equal '(b "text") (cadr stanzas))
143 (assert-equal '(c (d)) (caddr stanzas)))))
145 (test "incremental stanza assembly"
146 (let ((r (make-stanza-reader)))
147 (stanza-reader-feed! r "<stream:stream>")
148 (stanza-reader-feed! r "<iq type=\"result\">")
149 (assert-equal '() (stanza-reader-stanzas! r))
150 (stanza-reader-feed! r "<query><item jid=\"a@b\"/></query>")
151 (assert-equal '() (stanza-reader-stanzas! r))
152 (stanza-reader-feed! r "</iq>")
153 (let ((stanzas (stanza-reader-stanzas! r)))
154 (assert-equal 1 (length stanzas)))))
156 (test "stanza-reader-reset! clears state"
157 (let ((r (make-stanza-reader)))
158 (stanza-reader-feed! r "<stream:stream xmlns='jabber:client'>")
159 (stanza-reader-feed! r "<partial>text")
160 (stanza-reader-reset! r)
161 (assert-false (stanza-reader-stream-attrs r))
162 (assert-equal '() (stanza-reader-stanzas! r))
163 ;; Can feed new stream after reset
164 (stanza-reader-feed! r "<stream:stream xmlns='jabber:client'>")
165 (stanza-reader-feed! r "<message><body>After reset</body></message>")
166 (let ((stanzas (stanza-reader-stanzas! r)))
167 (assert-equal 1 (length stanzas))
168 (assert-equal '(message (body "After reset")) (car stanzas)))))
170 (test "XMPP features stanza"
171 (let ((r (make-stanza-reader)))
172 (stanza-reader-feed! r "<stream:stream>")
173 (stanza-reader-feed! r "<stream:features><starttls xmlns=\"urn:ietf:params:xml:ns:xmpp-tls\"><required/></starttls></stream:features>")
174 (let ((stanzas (stanza-reader-stanzas! r)))
175 (assert-equal 1 (length stanzas))
176 (let ((features (car stanzas)))
177 (assert-equal 'stream:features (car features)))))))
179;; ============================================================
180;; Convenience Functions
181;; ============================================================
183(test-group "xml->sxml"
184 (test "simple element"
185 (assert-equal '(p "Hello") (xml->sxml "<p>Hello</p>")))
187 (test "element with attributes"
188 (assert-equal '(div (@ (class "main")) "text")
189 (xml->sxml "<div class=\"main\">text</div>")))
191 (test "nested elements"
192 (assert-equal '(a (b "text"))
193 (xml->sxml "<a><b>text</b></a>")))
195 (test "self-closing element"
196 (assert-equal '(br) (xml->sxml "<br/>")))
198 (test "empty string returns #f"
199 (assert-false (xml->sxml ""))))
201(test-group "xml->sxml*"
202 (test "multiple elements"
203 (assert-equal '((a) (b "text"))
204 (xml->sxml* "<a/><b>text</b>")))
206 (test "single element"
207 (assert-equal '((p "hello"))
208 (xml->sxml* "<p>hello</p>")))
210 (test "empty string"
211 (assert-equal '() (xml->sxml* ""))))
213(run-tests)