Commit63b10c69Recorded20 Feb 2026Repositorysigil-sxml
feat: Add streaming XML parser and R7RS char classification builtins
Message
Add (sigil sxml reader) module with SAX-style streaming XML parser, XMPP stanza reader, and xml->sxml convenience functions. Add char-alphabetic?, char-numeric?, and char-whitespace? builtins.
Changed
src/sigil/sxml/reader.sgl | 718 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
test/test-xml-reader.sgl | 213 +++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 931 insertions(+)Diff
src/sigil/sxml/reader.sgladded
@@ -0,0 +1,718 @@
+1
;;; (sigil sxml reader) - Streaming XML Parser+2
;;;+3
;;; A character-by-character streaming XML parser that converts XML to SXML.+4
;;; Designed for protocols like XMPP where XML arrives incrementally over+5
;;; a network connection.+6
;;;+7
;;; ## Low-level API (SAX-like)+8
;;;+9
;;; ```scheme+10
;;; (define p (make-xml-parser))+11
;;; (xml-parser-feed! p "<message to=\"[email protected]\"><body>Hi</body></message>")+12
;;; (xml-parser-events! p)+13
;;; ; => ((open-tag message ((to "[email protected]")))+14
;;; ; (open-tag body ())+15
;;; ; (text "Hi")+16
;;; ; (close-tag body)+17
;;; ; (close-tag message))+18
;;; ```+19
;;;+20
;;; ## Stanza reader (XMPP-oriented)+21
;;;+22
;;; ```scheme+23
;;; (define r (make-stanza-reader))+24
;;; (stanza-reader-feed! r "<stream:stream xmlns='jabber:client'>")+25
;;; (stanza-reader-feed! r "<message><body>Hello</body></message>")+26
;;; (stanza-reader-stanzas! r)+27
;;; ; => ((message (body "Hello")))+28
;;; ```+29
;;;+30
;;; ## Convenience+31
;;;+32
;;; ```scheme+33
;;; (xml->sxml "<p>Hello</p>") ; => (p "Hello")+34
;;; (xml->sxml* "<a/><b/>") ; => ((a) (b))+35
;;; ```+36
+37
(define-library (sigil sxml reader)+38
(import (sigil core)+39
(sigil string)+40
(sigil io))+41
+42
(export+43
;; Low-level SAX-like parser+44
make-xml-parser+45
xml-parser-feed!+46
xml-parser-events!+47
+48
;; Stanza reader (XMPP-oriented)+49
make-stanza-reader+50
stanza-reader-feed!+51
stanza-reader-stanzas!+52
stanza-reader-stream-attrs+53
stanza-reader-reset!+54
+55
;; Convenience+56
xml->sxml+57
xml->sxml*)+58
+59
(begin+60
+61
;; ============================================================+62
;; Character Classification+63
;; ============================================================+64
+65
(define (xml-name-start-char? c)+66
(or (char-alphabetic? c)+67
(char=? c #\_)+68
(char=? c #\:)))+69
+70
(define (xml-name-char? c)+71
(or (xml-name-start-char? c)+72
(char-numeric? c)+73
(char=? c #\-)+74
(char=? c #\.)))+75
+76
(define (xml-whitespace? c)+77
(char-whitespace? c))+78
+79
;; ============================================================+80
;; XML Entity Decoding+81
;; ============================================================+82
+83
(define (decode-entity name)+84
(cond+85
((string=? name "amp") "&")+86
((string=? name "lt") "<")+87
((string=? name "gt") ">")+88
((string=? name "quot") "\"")+89
((string=? name "apos") "'")+90
((and (> (string-length name) 1)+91
(char=? (string-ref name 0) #\#))+92
(let ((code (if (and (> (string-length name) 2)+93
(char=? (string-ref name 1) #\x))+94
(string->number (substring name 2 (string-length name)) 16)+95
(string->number (substring name 1 (string-length name))))))+96
(if code+97
(string (integer->char code))+98
#f)))+99
(else #f)))+100
+101
;; ============================================================+102
;; Low-level XML Parser+103
;; ============================================================+104
+105
;; Parser states+106
;; text - reading text content+107
;; tag-open - saw '<'+108
;; tag-name - reading tag name+109
;; tag-space - whitespace after tag name or attribute+110
;; attr-name - reading attribute name+111
;; attr-eq - saw '=' after attribute name+112
;; attr-value - reading quoted attribute value+113
;; close-tag - reading closing tag name+114
;; self-close - saw '/' in tag (self-closing)+115
;; comment - inside <!-- ... -->+116
;; pi - inside <? ... ?>+117
;; cdata - inside <![CDATA[ ... ]]>+118
;; entity - reading &entity;+119
+120
;;; Create a new streaming XML parser.+121
;;;+122
;;; Returns a parser object that can be fed XML data incrementally.+123
(define (make-xml-parser)+124
(vector 'text ; 0: state+125
'() ; 1: events (reverse order)+126
(open-output-string) ; 2: buffer (current text accumulator)+127
"" ; 3: tag-name+128
'() ; 4: attributes (reverse order)+129
"" ; 5: current attr name+130
#f ; 6: attr quote char+131
"" ; 7: entity buffer+132
0 ; 8: comment/cdata sub-state+133
))+134
+135
(define (parser-state p) (vector-ref p 0))+136
(define (parser-events p) (vector-ref p 1))+137
(define (parser-buffer p) (vector-ref p 2))+138
(define (parser-tag-name p) (vector-ref p 3))+139
(define (parser-attrs p) (vector-ref p 4))+140
(define (parser-attr-name p) (vector-ref p 5))+141
(define (parser-attr-quote p) (vector-ref p 6))+142
(define (parser-entity-buf p) (vector-ref p 7))+143
(define (parser-sub-state p) (vector-ref p 8))+144
+145
(define (set-parser-state! p v) (vector-set! p 0 v))+146
(define (set-parser-events! p v) (vector-set! p 1 v))+147
(define (set-parser-buffer! p v) (vector-set! p 2 v))+148
(define (set-parser-tag-name! p v) (vector-set! p 3 v))+149
(define (set-parser-attrs! p v) (vector-set! p 4 v))+150
(define (set-parser-attr-name! p v) (vector-set! p 5 v))+151
(define (set-parser-attr-quote! p v) (vector-set! p 6 v))+152
(define (set-parser-entity-buf! p v) (vector-set! p 7 v))+153
(define (set-parser-sub-state! p v) (vector-set! p 8 v))+154
+155
(define (parser-emit! p event)+156
(set-parser-events! p (cons event (parser-events p))))+157
+158
(define (parser-flush-text! p)+159
(let ((text (get-output-string (parser-buffer p))))+160
(when (> (string-length text) 0)+161
(parser-emit! p (list 'text text))+162
(set-parser-buffer! p (open-output-string)))))+163
+164
(define (parser-buf-write! p c)+165
(write-char c (parser-buffer p)))+166
+167
(define (parser-buf-write-string! p s)+168
(display s (parser-buffer p)))+169
+170
(define (parser-buf-string p)+171
(get-output-string (parser-buffer p)))+172
+173
(define (parser-reset-buf! p)+174
(set-parser-buffer! p (open-output-string)))+175
+176
;;; Feed a string of XML data to the parser.+177
;;;+178
;;; Events are accumulated and can be retrieved with `xml-parser-events!`.+179
(define (xml-parser-feed! p data)+180
(let ((len (string-length data)))+181
(let loop ((i 0))+182
(when (< i len)+183
(parse-char p (string-ref data i))+184
(loop (+ i 1))))))+185
+186
;;; Retrieve and clear accumulated events.+187
;;;+188
;;; Returns a list of events, each being one of:+189
;;; (open-tag name attrs) - Opening tag with attribute alist+190
;;; (close-tag name) - Closing tag+191
;;; (text string) - Text content+192
;;; (error message) - Parse error+193
(define (xml-parser-events! p)+194
(let ((events (reverse (parser-events p))))+195
(set-parser-events! p '())+196
events))+197
+198
;; Main character dispatch+199
(define (parse-char p c)+200
(let ((state (parser-state p)))+201
(cond+202
((eq? state 'text) (parse-text p c))+203
((eq? state 'tag-open) (parse-tag-open p c))+204
((eq? state 'tag-name) (parse-tag-name p c))+205
((eq? state 'tag-space) (parse-tag-space p c))+206
((eq? state 'attr-name) (parse-attr-name p c))+207
((eq? state 'attr-eq) (parse-attr-eq p c))+208
((eq? state 'attr-value) (parse-attr-value p c))+209
((eq? state 'attr-entity) (parse-attr-entity p c))+210
((eq? state 'close-tag) (parse-close-tag p c))+211
((eq? state 'self-close) (parse-self-close p c))+212
((eq? state 'comment) (parse-comment p c))+213
((eq? state 'pi) (parse-pi p c))+214
((eq? state 'cdata) (parse-cdata p c))+215
((eq? state 'entity) (parse-entity p c)))))+216
+217
;; State: text - reading text content between tags+218
(define (parse-text p c)+219
(cond+220
((char=? c #\<)+221
(parser-flush-text! p)+222
(set-parser-state! p 'tag-open))+223
((char=? c #\&)+224
(set-parser-entity-buf! p "")+225
(set-parser-state! p 'entity))+226
(else+227
(parser-buf-write! p c))))+228
+229
;; State: entity - reading &entity;+230
(define (parse-entity p c)+231
(cond+232
((char=? c #\;)+233
(let ((decoded (decode-entity (parser-entity-buf p))))+234
(if decoded+235
(parser-buf-write-string! p decoded)+236
(begin+237
(parser-buf-write! p #\&)+238
(parser-buf-write-string! p (parser-entity-buf p))+239
(parser-buf-write! p #\;))))+240
(set-parser-state! p 'text))+241
((or (char-alphabetic? c) (char-numeric? c) (char=? c #\#) (char=? c #\x))+242
(set-parser-entity-buf! p (string-append (parser-entity-buf p) (string c))))+243
(else+244
;; Malformed entity - emit as text+245
(parser-buf-write! p #\&)+246
(parser-buf-write-string! p (parser-entity-buf p))+247
(parser-buf-write! p c)+248
(set-parser-state! p 'text))))+249
+250
;; State: tag-open - saw '<', determine tag type+251
(define (parse-tag-open p c)+252
(cond+253
((char=? c #\/)+254
(parser-reset-buf! p)+255
(set-parser-state! p 'close-tag))+256
((char=? c #\!)+257
(set-parser-sub-state! p 1)+258
(set-parser-state! p 'comment))+259
((char=? c #\?)+260
(parser-reset-buf! p)+261
(set-parser-sub-state! p 0)+262
(set-parser-state! p 'pi))+263
((xml-name-start-char? c)+264
(parser-reset-buf! p)+265
(parser-buf-write! p c)+266
(set-parser-attrs! p '())+267
(set-parser-state! p 'tag-name))+268
(else+269
;; Malformed - emit '<' as text+270
(parser-buf-write! p #\<)+271
(parser-buf-write! p c)+272
(set-parser-state! p 'text))))+273
+274
;; State: tag-name - reading opening tag name+275
(define (parse-tag-name p c)+276
(cond+277
((xml-name-char? c)+278
(parser-buf-write! p c))+279
((xml-whitespace? c)+280
(set-parser-tag-name! p (parser-buf-string p))+281
(parser-reset-buf! p)+282
(set-parser-state! p 'tag-space))+283
((char=? c #\>)+284
(set-parser-tag-name! p (parser-buf-string p))+285
(parser-reset-buf! p)+286
(emit-open-tag! p))+287
((char=? c #\/)+288
(set-parser-tag-name! p (parser-buf-string p))+289
(parser-reset-buf! p)+290
(set-parser-state! p 'self-close))+291
(else+292
(parser-buf-write! p c))))+293
+294
;; State: tag-space - whitespace in tag, looking for attr or close+295
(define (parse-tag-space p c)+296
(cond+297
((xml-whitespace? c) #t) ; skip+298
((char=? c #\>)+299
(emit-open-tag! p))+300
((char=? c #\/)+301
(set-parser-state! p 'self-close))+302
((xml-name-start-char? c)+303
(parser-reset-buf! p)+304
(parser-buf-write! p c)+305
(set-parser-state! p 'attr-name))+306
(else+307
(parser-emit! p (list 'error (string-append "unexpected char in tag: " (string c))))+308
(set-parser-state! p 'text))))+309
+310
;; State: attr-name - reading attribute name+311
(define (parse-attr-name p c)+312
(cond+313
((xml-name-char? c)+314
(parser-buf-write! p c))+315
((char=? c #\=)+316
(set-parser-attr-name! p (parser-buf-string p))+317
(parser-reset-buf! p)+318
(set-parser-state! p 'attr-eq))+319
((xml-whitespace? c)+320
;; Attribute without value (like in HTML)+321
(let ((name (parser-buf-string p)))+322
(parser-reset-buf! p)+323
(set-parser-attrs! p (cons (list (string->symbol name) name) (parser-attrs p)))+324
(set-parser-state! p 'tag-space)))+325
(else+326
(parser-emit! p (list 'error (string-append "unexpected char in attr name: " (string c))))+327
(set-parser-state! p 'text))))+328
+329
;; State: attr-eq - saw '=' after attribute name, expect quote+330
(define (parse-attr-eq p c)+331
(cond+332
((or (char=? c #\") (char=? c #\'))+333
(set-parser-attr-quote! p c)+334
(parser-reset-buf! p)+335
(set-parser-state! p 'attr-value))+336
((xml-whitespace? c) #t) ; skip whitespace before quote+337
(else+338
(parser-emit! p (list 'error "expected quote after ="))+339
(set-parser-state! p 'text))))+340
+341
;; State: attr-value - reading quoted attribute value+342
(define (parse-attr-value p c)+343
(cond+344
((char=? c (parser-attr-quote p))+345
(let ((value (parser-buf-string p))+346
(name (parser-attr-name p)))+347
(parser-reset-buf! p)+348
(set-parser-attrs! p (cons (list (string->symbol name) value) (parser-attrs p)))+349
(set-parser-state! p 'tag-space)))+350
((char=? c #\&)+351
;; Handle entities in attribute values inline+352
(set-parser-entity-buf! p "")+353
(set-parser-state! p 'attr-entity))+354
(else+355
(parser-buf-write! p c))))+356
+357
;; Emit an open-tag event+358
(define (emit-open-tag! p)+359
(let ((name (parser-tag-name p))+360
(attrs (reverse (parser-attrs p))))+361
(parser-emit! p (list 'open-tag (string->symbol name) attrs))+362
(parser-reset-buf! p)+363
(set-parser-state! p 'text)))+364
+365
;; State: self-close - saw '/' in tag, expect '>'+366
(define (parse-self-close p c)+367
(cond+368
((char=? c #\>)+369
(let ((name (parser-tag-name p))+370
(attrs (reverse (parser-attrs p))))+371
(parser-emit! p (list 'open-tag (string->symbol name) attrs))+372
(parser-emit! p (list 'close-tag (string->symbol name)))+373
(parser-reset-buf! p)+374
(set-parser-state! p 'text)))+375
(else+376
(parser-emit! p (list 'error "expected > after /"))+377
(set-parser-state! p 'text))))+378
+379
;; State: close-tag - reading closing tag name+380
(define (parse-close-tag p c)+381
(cond+382
((char=? c #\>)+383
(let ((name (parser-buf-string p)))+384
(parser-reset-buf! p)+385
(parser-emit! p (list 'close-tag (string->symbol name)))+386
(set-parser-state! p 'text)))+387
((xml-whitespace? c) #t) ; skip whitespace in closing tag+388
(else+389
(parser-buf-write! p c))))+390
+391
;; State: comment - inside <!-- ... --> or <![CDATA[ ... ]]>+392
;; sub-state: 1=saw !, 2=saw !-, 3=in comment, 4=saw -, 5=saw --+393
;; 10=saw ![, 11=saw ![C, ... 16=saw ![CDATA[, 17=in CDATA+394
(define (parse-comment p c)+395
(let ((sub (parser-sub-state p)))+396
(cond+397
;; Detecting comment vs CDATA+398
((= sub 1)+399
(cond+400
((char=? c #\-) (set-parser-sub-state! p 2))+401
((char=? c #\[) (set-parser-sub-state! p 10))+402
(else+403
;; DOCTYPE or other - skip until >+404
(set-parser-sub-state! p 20))))+405
((= sub 2)+406
(if (char=? c #\-)+407
(set-parser-sub-state! p 3)+408
(begin (set-parser-sub-state! p 20))))+409
;; In comment body+410
((= sub 3)+411
(if (char=? c #\-)+412
(set-parser-sub-state! p 4)))+413
((= sub 4)+414
(if (char=? c #\-)+415
(set-parser-sub-state! p 5)+416
(set-parser-sub-state! p 3)))+417
((= sub 5)+418
(if (char=? c #\>)+419
(begin+420
(parser-reset-buf! p)+421
(set-parser-state! p 'text))+422
(set-parser-sub-state! p 3)))+423
;; CDATA detection: ![CDATA[+424
((and (>= sub 10) (<= sub 15))+425
(let ((expected "CDATA["))+426
(if (char=? c (string-ref expected (- sub 10)))+427
(if (= sub 15)+428
(begin+429
(parser-reset-buf! p)+430
(set-parser-state! p 'cdata)+431
(set-parser-sub-state! p 0))+432
(set-parser-sub-state! p (+ sub 1)))+433
(set-parser-sub-state! p 20))))+434
;; Skip until > (DOCTYPE etc)+435
((= sub 20)+436
(when (char=? c #\>)+437
(parser-reset-buf! p)+438
(set-parser-state! p 'text))))))+439
+440
;; State: cdata - inside <![CDATA[ ... ]]>+441
;; sub-state: 0=normal, 1=saw ], 2=saw ]]+442
(define (parse-cdata p c)+443
(let ((sub (parser-sub-state p)))+444
(cond+445
((= sub 0)+446
(if (char=? c #\])+447
(set-parser-sub-state! p 1)+448
(parser-buf-write! p c)))+449
((= sub 1)+450
(if (char=? c #\])+451
(set-parser-sub-state! p 2)+452
(begin+453
(parser-buf-write! p #\])+454
(parser-buf-write! p c)+455
(set-parser-sub-state! p 0))))+456
((= sub 2)+457
(if (char=? c #\>)+458
(begin+459
(parser-flush-text! p)+460
(set-parser-state! p 'text)+461
(set-parser-sub-state! p 0))+462
(begin+463
(parser-buf-write! p #\])+464
(parser-buf-write! p #\])+465
(parser-buf-write! p c)+466
(set-parser-sub-state! p 0)))))))+467
+468
;; State: pi - inside <? ... ?>+469
;; sub-state: 0=normal, 1=saw ?+470
(define (parse-pi p c)+471
(let ((sub (parser-sub-state p)))+472
(cond+473
((= sub 0)+474
(when (char=? c #\?)+475
(set-parser-sub-state! p 1)))+476
((= sub 1)+477
(if (char=? c #\>)+478
(begin+479
(parser-reset-buf! p)+480
(set-parser-state! p 'text)+481
(set-parser-sub-state! p 0))+482
(set-parser-sub-state! p 0))))))+483
+484
;; Handle entities within attribute values+485
(define (parse-attr-entity p c)+486
(cond+487
((char=? c #\;)+488
(let ((decoded (decode-entity (parser-entity-buf p))))+489
(if decoded+490
(parser-buf-write-string! p decoded)+491
(begin+492
(parser-buf-write! p #\&)+493
(parser-buf-write-string! p (parser-entity-buf p))+494
(parser-buf-write! p #\;))))+495
(set-parser-state! p 'attr-value))+496
((or (char-alphabetic? c) (char-numeric? c) (char=? c #\#) (char=? c #\x))+497
(set-parser-entity-buf! p (string-append (parser-entity-buf p) (string c))))+498
(else+499
(parser-buf-write! p #\&)Showing the first 500 of 719 diff lines for this file. This diff is INCOMPLETE; read the file or clone the repository for the rest.
test/test-xml-reader.sgladded
@@ -0,0 +1,213 @@
+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)))))+16
+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)))))+25
+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)))))+32
+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)))))+39
+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)))))+51
+52
(test "text entities"+53
(let ((p (make-xml-parser)))+54
(xml-parser-feed! p "<p>a & b < c</p>")+55
(let ((events (xml-parser-events! p)))+56
(assert-equal '(text "a & b < c") (cadr events)))))+57
+58
(test "attribute entities"+59
(let ((p (make-xml-parser)))+60
(xml-parser-feed! p "<a title=\"a & b\"/>")+61
(let ((events (xml-parser-events! p)))+62
(assert-equal '(open-tag a ((title "a & b")))+63
(car events)))))+64
+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)))))+77
+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)))))+84
+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)))))+92
+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))))))+100
+101
;; ============================================================+102
;; Stanza Reader+103
;; ============================================================+104
+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))))))+115
+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)))))+123
+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))))))+134
+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)))))+144
+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)))))+155
+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)))))+169
+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)))))))+178
+179
;; ============================================================+180
;; Convenience Functions+181
;; ============================================================+182
+183
(test-group "xml->sxml"+184
(test "simple element"+185
(assert-equal '(p "Hello") (xml->sxml "<p>Hello</p>")))+186
+187
(test "element with attributes"+188
(assert-equal '(div (@ (class "main")) "text")+189
(xml->sxml "<div class=\"main\">text</div>")))+190
+191
(test "nested elements"+192
(assert-equal '(a (b "text"))+193
(xml->sxml "<a><b>text</b></a>")))+194
+195
(test "self-closing element"+196
(assert-equal '(br) (xml->sxml "<br/>")))+197
+198
(test "empty string returns #f"+199
(assert-false (xml->sxml ""))))+200
+201
(test-group "xml->sxml*"+202
(test "multiple elements"+203
(assert-equal '((a) (b "text"))+204
(xml->sxml* "<a/><b>text</b>")))+205
+206
(test "single element"+207
(assert-equal '((p "hello"))+208
(xml->sxml* "<p>hello</p>")))+209
+210
(test "empty string"+211
(assert-equal '() (xml->sxml* ""))))+212
+213
(run-tests)