af57e0419c
It was very hard to figure out why � is invalid. Both the XML 1.0 and 1.1 specs say that a CharRef can be '&#' [0-9]+ ';' (sec 4.1), but there is a note on the side that it must also be a valid Char. The Char definition (sec 2.2) then lays out which characters are valid. (The 1.0 and 1.1 specs disagree though.) I've gone with the 1.1 definition. I did not update the rest of the reader to disallow those characters in pcdata segments. If this hurts you or you morally disagree, submit another PR, please.
789 lines
31 KiB
Racket
789 lines
31 KiB
Racket
#lang racket
|
|
(require rackunit
|
|
rackunit/text-ui
|
|
xml
|
|
xml/plist
|
|
mzlib/etc
|
|
"to-list.rkt")
|
|
|
|
;; test-bad-read-input : format-str str -> void
|
|
;; First argument is the input, second is the error message
|
|
(define ((mk-test-read-xml/exn read-xml) format-str err-string)
|
|
(define str (format format-str))
|
|
(test-exn
|
|
str
|
|
(lambda (x)
|
|
(regexp-match (regexp-quote err-string) (exn-message x)))
|
|
(lambda ()
|
|
(read-xml (open-input-string str)))))
|
|
|
|
(define test-read-xml/exn (mk-test-read-xml/exn read-xml))
|
|
(define (test-read-xml str xml #:document-different? [diff? #f])
|
|
(unless diff?
|
|
(test-equal? str (document->list (read-xml/document (open-input-string str))) xml))
|
|
(test-equal? str (document->list (read-xml (open-input-string str))) xml))
|
|
|
|
(define test-syntax:read-xml/exn (mk-test-read-xml/exn syntax:read-xml))
|
|
(define (test-syntax:read-xml str xml)
|
|
(test-equal? str (syntax->datum (syntax:read-xml (open-input-string str))) xml))
|
|
|
|
(define test-read-xml/element/exn (mk-test-read-xml/exn read-xml/element))
|
|
(define (test-read-xml/element str xml)
|
|
(test-equal? str (element->list (read-xml/element (open-input-string str))) xml))
|
|
|
|
(define test-syntax:read-xml/element/exn (mk-test-read-xml/exn syntax:read-xml/element))
|
|
(define (test-syntax:read-xml/element str xml)
|
|
(test-equal? str (syntax->datum (syntax:read-xml/element (open-input-string str))) xml))
|
|
|
|
(define (test-write-xml str)
|
|
(test-equal? str (with-output-to-string (lambda () (write-xml (read-xml (open-input-string str))))) str))
|
|
(define (test-write-xml/content str)
|
|
(test-equal? str (with-output-to-string (lambda () (write-xml/content (document-element (read-xml (open-input-string str)))))) str))
|
|
|
|
(define (test-display-xml str res)
|
|
(test-equal? str (with-output-to-string (lambda () (display-xml (read-xml (open-input-string str))))) res))
|
|
(define (test-display-xml/content str res)
|
|
(test-equal? str (with-output-to-string (lambda () (display-xml/content (document-element (read-xml (open-input-string str)))))) res))
|
|
|
|
(define (test-xexpr? xe)
|
|
(test-not-false (format "~S" xe) (xexpr? xe)))
|
|
(define (test-not-xexpr? xe)
|
|
(test-false (format "~S" xe) (xexpr? xe)))
|
|
|
|
(define (contract->predicate c)
|
|
(lambda (v)
|
|
(with-handlers ([exn:fail:contract?
|
|
(lambda (x) #f)])
|
|
(contract c v 'pos 'neg)
|
|
#t)))
|
|
|
|
(define xml-tests
|
|
(test-suite
|
|
"XML"
|
|
|
|
(test-suite
|
|
"Legacy tests"
|
|
|
|
(test-suite
|
|
"DOCTYPE"
|
|
|
|
(let ()
|
|
(define source-string #<<END
|
|
<!DOCTYPE html PUBLIC
|
|
"-//W3C//DTD XHTML 1.0 Transitional//EN"
|
|
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
|
|
<html xmlns="http://www.w3.org/1999/xhtml"> </html>
|
|
END
|
|
)
|
|
|
|
(define source-document
|
|
(read-xml (open-input-string source-string)))
|
|
(define result-string
|
|
(with-output-to-string (lambda () (write-xml source-document))))
|
|
(define expected-string #<<END
|
|
<html xmlns="http://www.w3.org/1999/xhtml"> </html>
|
|
END
|
|
)
|
|
(test-equal?
|
|
"DOCTYPE dropping" result-string expected-string)))
|
|
|
|
(local
|
|
[(define a-pi (make-p-i #f #f 'foo "bar"))
|
|
(define a-p (make-prolog empty #f empty))
|
|
(define a-p/pi (make-prolog (list a-pi) #f (list)))
|
|
(define a-d0
|
|
(make-document a-p (make-element #f #f 'html empty empty)
|
|
empty))
|
|
(define a-d1
|
|
(make-document a-p (make-element #f #f 'html empty empty)
|
|
(list a-pi)))
|
|
(define a-d2
|
|
(make-document a-p/pi (make-element #f #f 'html empty empty)
|
|
(list a-pi)))]
|
|
(test-suite
|
|
"PIs"
|
|
(test-equal? "Display XML w/o pis"
|
|
(with-output-to-string (lambda () (display-xml a-d0)))
|
|
"\n<html />")
|
|
(test-equal? "Display XML w/ pi in doc-misc"
|
|
(with-output-to-string (lambda () (display-xml a-d1)))
|
|
"\n<html /><?foo bar?>\n")
|
|
(test-equal? "Display XML w/ pi in doc-misc and prolog"
|
|
(with-output-to-string (lambda () (display-xml a-d2)))
|
|
"<?foo bar?>\n\n<html /><?foo bar?>\n"))))
|
|
|
|
(test-suite
|
|
"Datatypes"
|
|
(test-suite
|
|
"xexpr"
|
|
(test-xexpr? "string")
|
|
(test-xexpr? (list 'a (list (list 'href "#")) "content"))
|
|
(test-xexpr? (list 'p "one" "two" "three"))
|
|
(test-xexpr? 'nbsp)
|
|
(test-xexpr? 10)
|
|
(test-not-xexpr? 0)
|
|
(test-xexpr? (make-cdata #f #f "unquoted <b>"))
|
|
(test-xexpr? (make-comment "Comment!"))
|
|
(test-xexpr? (make-pcdata #f #f "quoted <b>"))
|
|
|
|
(test-not-xexpr? (list 'a (list (list 'href)) "content"))
|
|
|
|
(test-not-xexpr? +)
|
|
(test-not-xexpr? #f))
|
|
|
|
(test-not-false "xexpr/c" (contract? xexpr/c))
|
|
|
|
(test-not-false "document" (document? (make-document (make-prolog empty #f empty) (make-element #f #f 'br empty empty) empty)))
|
|
|
|
(test-not-false "prolog" (prolog? (make-prolog empty #f empty)))
|
|
(let ([c1 (make-comment "c1")]
|
|
[c2 (make-comment "c2")])
|
|
(test-equal? "prolog" (prolog-misc2 (make-prolog empty #f (list c1 c2)))
|
|
(list c1 c2)))
|
|
|
|
(test-not-false "document-type" (document-type? (make-document-type 'name (make-external-dtd "string") #f)))
|
|
|
|
(test-not-false "external-dtd" (external-dtd? (make-external-dtd "string")))
|
|
(test-not-false "external-dtd/public" (external-dtd/public? (make-external-dtd/public "string" "public")))
|
|
(test-not-false "external-dtd/system" (external-dtd/system? (make-external-dtd/system "string")))
|
|
|
|
(test-not-false "element" (element? (make-element #f #f 'br empty empty)))
|
|
|
|
(local [(define content? (contract->predicate content/c))]
|
|
(test-suite
|
|
"content?"
|
|
(test-not-false "content? pcdata" (content? (make-pcdata #f #f "pcdata")))
|
|
(test-not-false "content? element" (content? (make-element #f #f 'br empty empty)))
|
|
(test-not-false "content? entity" (content? (make-entity #f #f 'nbsp)))
|
|
(test-not-false "content? comment" (content? (make-comment "string")))
|
|
(test-not-false "content? cdata" (content? (make-cdata #f #f "cdata")))))
|
|
|
|
(test-not-false "attribute" (attribute? (make-attribute #f #f 'name "value")))
|
|
|
|
(test-not-false "entity symbol" (entity? (make-entity #f #f 'nbsp)))
|
|
(test-not-false "entity number" (entity? (make-entity #f #f 10)))
|
|
|
|
(test-not-false "pcdata" (pcdata? (make-pcdata #f #f "string")))
|
|
|
|
(test-not-false "cdata" (cdata? (make-cdata #f #f "string")))
|
|
|
|
(test-not-false "p-i" (p-i? (make-p-i #f #f 'target "instruction")))
|
|
|
|
(test-not-false "comment" (comment? (make-comment "text")))
|
|
|
|
(test-not-false "source" (source? (make-source 'start 'stop)))
|
|
(test-not-false "source" (source? (make-source (make-location 1 2 3) 'stop)))
|
|
(test-not-false "source" (source? (make-source 'start (make-location 1 2 3))))
|
|
(test-not-false "source" (source? (make-source (make-location 1 2 3) (make-location 4 5 6)))))
|
|
|
|
(test-suite
|
|
"Reading and Writing XML"
|
|
|
|
(test-suite
|
|
"read-xml"
|
|
(test-read-xml/exn "<" "read-xml: lex-error: at position 1.1/2: unexpected eof")
|
|
(test-read-xml/exn "<a>" "read-xml: parse-error: unclosed `a' tag at [1.0/1 1.3/4]")
|
|
(test-read-xml/exn
|
|
"<a></b>"
|
|
"read-xml: parse-error: start tag `a' at [1.0/1 1.3/4] doesn't match end tag `b' at [1.3/4 1.7/8]")
|
|
(test-read-xml/exn
|
|
"<a <a>" "read-xml: lex-error: at position 1.4/5: expected / or > to close tag `a'")
|
|
|
|
(test-read-xml/exn "~n<" "read-xml: lex-error: at position 2.1/3: unexpected eof")
|
|
(test-read-xml/exn "~n<a>" "read-xml: parse-error: unclosed `a' tag at [2.0/2 2.3/5]")
|
|
(test-read-xml/exn
|
|
"~n<a></b>"
|
|
"read-xml: parse-error: start tag `a' at [2.0/2 2.3/5] doesn't match end tag `b' at [2.3/5 2.7/9]")
|
|
(test-read-xml/exn
|
|
"~n<a <a>" "read-xml: lex-error: at position 2.4/6: expected / or > to close tag `a'")
|
|
|
|
(test-read-xml/exn "" "read-xml: parse-error: expected root element - received #<eof>")
|
|
(test-read-xml/exn "<br /><br />" "read-xml: parse-error: extra stuff at end of document (element ")
|
|
|
|
(test-read-xml
|
|
"<doc><bold>hi</bold> there!</doc>"
|
|
'(make-document
|
|
(make-prolog (list) #f (list))
|
|
(make-element
|
|
(make-source (make-location 1 0 1) (make-location 1 33 34))
|
|
'doc
|
|
(list)
|
|
(list
|
|
(make-element
|
|
(make-source (make-location 1 5 6) (make-location 1 20 21))
|
|
'bold
|
|
(list)
|
|
(list (make-pcdata (make-source (make-location 1 11 12) (make-location 1 13 14)) "hi")))
|
|
(make-pcdata (make-source (make-location 1 20 21) (make-location 1 27 28)) " there!")))
|
|
(list)))
|
|
|
|
(test-read-xml
|
|
"<a href=\"#\">inner</a>"
|
|
'(make-document
|
|
(make-prolog (list) #f (list))
|
|
(make-element
|
|
(make-source (make-location 1 0 1) (make-location 1 21 22))
|
|
'a
|
|
(list (make-attribute (make-source (make-location 1 3 4) (make-location 1 11 12)) href "#"))
|
|
(list (make-pcdata (make-source (make-location 1 12 13) (make-location 1 17 18)) "inner")))
|
|
(list)))
|
|
|
|
(test-read-xml
|
|
"<root> </root>"
|
|
'(make-document
|
|
(make-prolog (list) #f (list))
|
|
(make-element
|
|
(make-source (make-location 1 0 1) (make-location 1 19 20))
|
|
'root
|
|
(list)
|
|
(list (make-entity (make-source (make-location 1 6 7) (make-location 1 12 13)) 'nbsp)))
|
|
(list)))
|
|
|
|
(test-read-xml
|
|
"<root>(</root>"
|
|
'(make-document
|
|
(make-prolog (list) #f (list))
|
|
(make-element
|
|
(make-source (make-location 1 0 1) (make-location 1 18 19))
|
|
'root
|
|
(list)
|
|
(list (make-entity (make-source (make-location 1 6 7) (make-location 1 11 12)) '40)))
|
|
(list)))
|
|
|
|
(test-read-xml/exn
|
|
"<root>�</root>"
|
|
"read-xml: lex-error: at position 1.10/11: not a well-formed numeric entity (does not match the production for Char, see XML 4.1)")
|
|
|
|
(test-read-xml
|
|
"<!-- comment --><br />"
|
|
'(make-document
|
|
(make-prolog (list) #f (list))
|
|
(make-element (make-source (make-location 1 16 17) (make-location 1 22 23)) 'br (list) (list))
|
|
(list)))
|
|
|
|
(test-read-xml
|
|
"<?xml version=\"1.0\"? encoding=\"UTF-8\" standalone=\"yes\"?><br />"
|
|
'(make-document
|
|
(make-prolog
|
|
(list
|
|
(make-p-i
|
|
(make-source (make-location 1 0 1) (make-location 1 56 57))
|
|
xml
|
|
"version=\"1.0\"? encoding=\"UTF-8\" standalone=\"yes\""))
|
|
#f
|
|
(list))
|
|
(make-element
|
|
(make-source (make-location 1 56 57) (make-location 1 62 63))
|
|
'br
|
|
(list)
|
|
(list))
|
|
(list)))
|
|
|
|
(test-read-xml #:document-different? #t
|
|
"<br /><?xml version=\"1.0\"? encoding=\"UTF-8\" standalone=\"yes\"?>"
|
|
'(make-document
|
|
(make-prolog (list) #f (list))
|
|
(make-element
|
|
(make-source (make-location 1 0 1) (make-location 1 6 7))
|
|
'br
|
|
(list)
|
|
(list))
|
|
(list
|
|
(make-p-i
|
|
(make-source (make-location 1 6 7) (make-location 1 62 63))
|
|
xml
|
|
"version=\"1.0\"? encoding=\"UTF-8\" standalone=\"yes\""))))
|
|
|
|
; XXX need more read-xml tests
|
|
|
|
)
|
|
|
|
(test-suite
|
|
"read-xml/element"
|
|
(test-read-xml/element/exn "<" "read-xml: lex-error: at position 1.1/2: unexpected eof")
|
|
(test-read-xml/element/exn "<a>" "read-xml: parse-error: unclosed `a' tag at [1.0/1 1.3/4]")
|
|
(test-read-xml/element/exn
|
|
"<a></b>"
|
|
"read-xml: parse-error: start tag `a' at [1.0/1 1.3/4] doesn't match end tag `b' at [1.3/4 1.7/8]")
|
|
(test-read-xml/element/exn
|
|
"<a <a>" "read-xml: lex-error: at position 1.4/5: expected / or > to close tag `a'")
|
|
|
|
(test-read-xml/element/exn "~n<" "read-xml: lex-error: at position 2.1/3: unexpected eof")
|
|
(test-read-xml/element/exn "~n<a>" "read-xml: parse-error: unclosed `a' tag at [2.0/2 2.3/5]")
|
|
(test-read-xml/element/exn
|
|
"~n<a></b>"
|
|
"read-xml: parse-error: start tag `a' at [2.0/2 2.3/5] doesn't match end tag `b' at [2.3/5 2.7/9]")
|
|
(test-read-xml/element/exn
|
|
"~n<a <a>" "read-xml: lex-error: at position 2.4/6: expected / or > to close tag `a'")
|
|
|
|
(test-read-xml/element/exn "" "read-xml: parse-error: expected root element - received #<eof>")
|
|
|
|
(test-read-xml/element
|
|
"<br /><br />"
|
|
'(make-element (make-source (make-location 1 0 1) (make-location 1 6 7)) 'br (list) (list)))
|
|
|
|
(test-read-xml/element
|
|
"<doc><bold>hi</bold> there!</doc>"
|
|
'(make-element
|
|
(make-source (make-location 1 0 1) (make-location 1 33 34))
|
|
'doc
|
|
(list)
|
|
(list
|
|
(make-element
|
|
(make-source (make-location 1 5 6) (make-location 1 20 21))
|
|
'bold
|
|
(list)
|
|
(list (make-pcdata (make-source (make-location 1 11 12) (make-location 1 13 14)) "hi")))
|
|
(make-pcdata (make-source (make-location 1 20 21) (make-location 1 27 28)) " there!"))))
|
|
|
|
(test-read-xml/element
|
|
"<a href=\"#\">inner</a>"
|
|
'(make-element
|
|
(make-source (make-location 1 0 1) (make-location 1 21 22))
|
|
'a
|
|
(list (make-attribute (make-source (make-location 1 3 4) (make-location 1 11 12)) href "#"))
|
|
(list (make-pcdata (make-source (make-location 1 12 13) (make-location 1 17 18)) "inner"))))
|
|
|
|
(test-read-xml/element
|
|
"<root> </root>"
|
|
'(make-element
|
|
(make-source (make-location 1 0 1) (make-location 1 19 20))
|
|
'root
|
|
(list)
|
|
(list (make-entity (make-source (make-location 1 6 7) (make-location 1 12 13)) 'nbsp))))
|
|
|
|
(test-read-xml/element
|
|
"<root>(</root>"
|
|
'(make-element
|
|
(make-source (make-location 1 0 1) (make-location 1 18 19))
|
|
'root
|
|
(list)
|
|
(list (make-entity (make-source (make-location 1 6 7) (make-location 1 11 12)) '40))))
|
|
|
|
(test-read-xml/element/exn
|
|
"<!-- comment --><br />"
|
|
"read-xml: parse-error: expected root element - received (comment ")
|
|
|
|
(test-read-xml/element
|
|
"<title><![CDATA[hello world[mp3]]]></title>"
|
|
'(make-element
|
|
(make-source (make-location 1 0 1) (make-location 1 43 44))
|
|
'title
|
|
(list)
|
|
(list (make-cdata (make-source (make-location 1 7 8) (make-location 1 35 36)) "<![CDATA[hello world[mp3]]]>"))))
|
|
|
|
(test-read-xml/element
|
|
"<title><![CDATA[]]]></title>"
|
|
'(make-element
|
|
(make-source (make-location 1 0 1) (make-location 1 28 29))
|
|
'title
|
|
(list)
|
|
(list (make-cdata (make-source (make-location 1 7 8) (make-location 1 20 21)) "<![CDATA[]]]>"))))
|
|
|
|
; XXX need more read-xml/element tests
|
|
|
|
)
|
|
|
|
(test-suite
|
|
"syntax:read-xml"
|
|
(test-syntax:read-xml/exn "<" "read-xml: lex-error: at position 1.1/2: unexpected eof")
|
|
(test-syntax:read-xml/exn "<a>" "read-xml: parse-error: unclosed `a' tag at [1.0/1 1.3/4]")
|
|
(test-syntax:read-xml/exn
|
|
"<a></b>"
|
|
"read-xml: parse-error: start tag `a' at [1.0/1 1.3/4] doesn't match end tag `b' at [1.3/4 1.7/8]")
|
|
(test-syntax:read-xml/exn
|
|
"<a <a>" "read-xml: lex-error: at position 1.4/5: expected / or > to close tag `a'")
|
|
|
|
(test-syntax:read-xml/exn "~n<" "read-xml: lex-error: at position 2.1/3: unexpected eof")
|
|
(test-syntax:read-xml/exn "~n<a>" "read-xml: parse-error: unclosed `a' tag at [2.0/2 2.3/5]")
|
|
(test-syntax:read-xml/exn
|
|
"~n<a></b>"
|
|
"read-xml: parse-error: start tag `a' at [2.0/2 2.3/5] doesn't match end tag `b' at [2.3/5 2.7/9]")
|
|
(test-syntax:read-xml/exn
|
|
"~n<a <a>" "read-xml: lex-error: at position 2.4/6: expected / or > to close tag `a'")
|
|
|
|
(test-syntax:read-xml/exn "" "read-xml: parse-error: expected root element - received #<eof>")
|
|
(test-syntax:read-xml/exn "<br /><br />" "read-xml: parse-error: extra stuff at end of document (element ")
|
|
|
|
(test-syntax:read-xml
|
|
"<doc><bold>hi</bold> there!</doc>"
|
|
'(doc () (bold () "hi") " there!"))
|
|
|
|
(test-syntax:read-xml
|
|
"<a href=\"#\">inner</a>"
|
|
'(a ([href "#"]) "inner"))
|
|
|
|
(test-syntax:read-xml
|
|
"<root> </root>"
|
|
'(root () nbsp))
|
|
|
|
(test-syntax:read-xml
|
|
"<root>(</root>"
|
|
'(root () 40))
|
|
|
|
(test-syntax:read-xml
|
|
"<!-- comment --><br />"
|
|
'(br ()))
|
|
|
|
; XXX need more syntax:read-xml tests
|
|
|
|
)
|
|
|
|
(test-suite
|
|
"syntax:read-xml/element"
|
|
(test-syntax:read-xml/element/exn "<" "read-xml: lex-error: at position 1.1/2: unexpected eof")
|
|
(test-syntax:read-xml/element/exn "<a>" "read-xml: parse-error: unclosed `a' tag at [1.0/1 1.3/4]")
|
|
(test-syntax:read-xml/element/exn
|
|
"<a></b>"
|
|
"read-xml: parse-error: start tag `a' at [1.0/1 1.3/4] doesn't match end tag `b' at [1.3/4 1.7/8]")
|
|
(test-syntax:read-xml/element/exn
|
|
"<a <a>" "read-xml: lex-error: at position 1.4/5: expected / or > to close tag `a'")
|
|
|
|
(test-syntax:read-xml/element/exn "~n<" "read-xml: lex-error: at position 2.1/3: unexpected eof")
|
|
(test-syntax:read-xml/element/exn "~n<a>" "read-xml: parse-error: unclosed `a' tag at [2.0/2 2.3/5]")
|
|
(test-syntax:read-xml/element/exn
|
|
"~n<a></b>"
|
|
"read-xml: parse-error: start tag `a' at [2.0/2 2.3/5] doesn't match end tag `b' at [2.3/5 2.7/9]")
|
|
(test-syntax:read-xml/element/exn
|
|
"~n<a <a>" "read-xml: lex-error: at position 2.4/6: expected / or > to close tag `a'")
|
|
|
|
(test-syntax:read-xml/element/exn "" "read-xml: parse-error: expected root element - received #<eof>")
|
|
(test-syntax:read-xml/element
|
|
"<br /><br />"
|
|
'(br ()))
|
|
|
|
(test-syntax:read-xml/element
|
|
"<doc><bold>hi</bold> there!</doc>"
|
|
'(doc () (bold () "hi") " there!"))
|
|
|
|
(test-syntax:read-xml/element
|
|
"<a href=\"#\">inner</a>"
|
|
'(a ([href "#"]) "inner"))
|
|
|
|
(test-syntax:read-xml/element
|
|
"<root> </root>"
|
|
'(root () nbsp))
|
|
|
|
(test-syntax:read-xml/element
|
|
"<root>(</root>"
|
|
'(root () 40))
|
|
|
|
(test-syntax:read-xml/element/exn
|
|
"<!-- comment --><br />"
|
|
"read-xml: parse-error: expected root element - received (comment ")
|
|
|
|
; XXX need more syntax:read-xml/element tests
|
|
|
|
)
|
|
|
|
(test-suite
|
|
"write-xml"
|
|
(test-write-xml "<doc><bold>hi</bold> there!</doc>")
|
|
(test-write-xml "<a href=\"#\">inner</a>")
|
|
(test-write-xml "<root> </root>")
|
|
(test-write-xml "<root>(</root>")
|
|
(test-write-xml "<br />")
|
|
; XXX need more write-xml tests
|
|
)
|
|
|
|
(test-suite
|
|
"write-xml/content"
|
|
(test-write-xml/content "<doc><bold>hi</bold> there!</doc>")
|
|
(test-write-xml/content "<a href=\"#\">inner</a>")
|
|
(test-write-xml/content "<root> </root>")
|
|
(test-write-xml/content "<root>(</root>")
|
|
(test-write-xml/content "<br />")
|
|
; XXX need more write-xml/content tests
|
|
)
|
|
|
|
(test-suite
|
|
"display-xml"
|
|
(test-display-xml "<doc><bold>hi</bold> there!</doc>" "\n<doc>\n <bold>\n hi\n </bold>\n there!\n</doc>")
|
|
(test-display-xml "<a href=\"#\">inner</a>" "\n<a href=\"#\">\n inner\n</a>")
|
|
(test-display-xml "<root> </root>" "\n<root> \n</root>")
|
|
(test-display-xml "<root>(</root>" "\n<root>(\n</root>")
|
|
(test-display-xml "<br />" "\n<br />")
|
|
; XXX need more display-xml tests
|
|
)
|
|
|
|
(test-suite
|
|
"display-xml/content"
|
|
(test-display-xml/content "<doc><bold>hi</bold> there!</doc>" "\n<doc>\n <bold>\n hi\n </bold>\n there!\n</doc>")
|
|
(test-display-xml/content "<a href=\"#\">inner</a>" "\n<a href=\"#\">\n inner\n</a>")
|
|
(test-display-xml/content "<root> </root>" "\n<root> \n</root>")
|
|
(test-display-xml/content "<root>(</root>" "\n<root>(\n</root>")
|
|
(test-display-xml/content "<br />" "\n<br />")
|
|
; XXX need more display-xml/content tests
|
|
)
|
|
)
|
|
|
|
(local
|
|
[(define (test-xml->xexpr str xe)
|
|
(test-equal? str (string->xexpr str) xe))
|
|
(define (test-xexpr->string xe str)
|
|
(test-equal? (format "~S" xe) (xexpr->string xe) str)
|
|
(test-equal? (format "~S" xe) (with-output-to-string (λ () (write-xexpr xe))) str)
|
|
(test-string->xexpr str xe))
|
|
(define (test-string->xexpr str xe)
|
|
(test-equal? str (string->xexpr str) xe))]
|
|
(test-suite
|
|
"XML and X-expression Conversions"
|
|
|
|
(test-suite
|
|
"xml->xexpr"
|
|
(test-xml->xexpr
|
|
"<doc><bold>hi</bold> there!</doc>"
|
|
'(doc () (bold () "hi") " there!"))
|
|
|
|
(test-xml->xexpr
|
|
"<a href=\"#\">inner</a>"
|
|
'(a ([href "#"]) "inner"))
|
|
|
|
(test-xml->xexpr
|
|
"<root> </root>"
|
|
'(root () nbsp))
|
|
|
|
(test-xml->xexpr
|
|
"<root>(</root>"
|
|
'(root () 40))
|
|
|
|
; XXX more xml->xexpr tests
|
|
)
|
|
|
|
(test-suite
|
|
"xexpr->string"
|
|
(test-xexpr->string '(doc () (bold () "hi") " there!")
|
|
"<doc><bold>hi</bold> there!</doc>")
|
|
(test-xexpr->string '(a ([href "#"]) "inner")
|
|
"<a href=\"#\">inner</a>")
|
|
(test-xexpr->string '(root () nbsp)
|
|
"<root> </root>")
|
|
(test-xexpr->string '(root () 40)
|
|
"<root>(</root>")
|
|
; XXX more xexpr->string tests
|
|
)
|
|
|
|
(test-suite
|
|
"string->xexpr"
|
|
(test-string->xexpr "<?foo bar?>\n\n<html /><?foo bar?>\n"
|
|
'(html ()))
|
|
(parameterize ([xexpr-drop-empty-attributes #t])
|
|
(test-string->xexpr "<?foo bar?>\n\n<html /><?foo bar?>\n"
|
|
'(html))))
|
|
|
|
(local
|
|
[(define (test-eliminate-whitespace tags choose str res)
|
|
(test-equal? (format "~S" (list tags choose str))
|
|
(with-output-to-string
|
|
(lambda ()
|
|
(write-xml/content ((eliminate-whitespace tags choose) (read-xml/element (open-input-string str))))))
|
|
res))
|
|
(define (test-eliminate-whitespace/exn tags choose str msg)
|
|
(test-exn (format "~S" (list tags choose str))
|
|
(lambda (x)
|
|
(and (exn? x)
|
|
(regexp-match (regexp-quote msg) (exn-message x))))
|
|
(lambda ()
|
|
(with-output-to-string
|
|
(lambda ()
|
|
(write-xml/content ((eliminate-whitespace tags choose) (read-xml/element (open-input-string str)))))))))
|
|
(define (truer x) #t)]
|
|
(test-suite
|
|
"eliminate-whitespace"
|
|
|
|
(test-equal? "Defaults"
|
|
(with-output-to-string
|
|
(lambda ()
|
|
(write-xml/content ((eliminate-whitespace) (read-xml/element (open-input-string "<html>\n<p>Hey</p></html>"))))))
|
|
"<html>\n<p>Hey</p></html>")
|
|
|
|
(test-eliminate-whitespace empty identity "<html>\n<p>Hey</p></html>" "<html>\n<p>Hey</p></html>")
|
|
(test-eliminate-whitespace/exn empty not "<html>\n<p>Hey</p></html>" "not allowed to contain text")
|
|
(test-eliminate-whitespace/exn empty truer "<html>\n<p>Hey</p></html>" "not allowed to contain text")
|
|
|
|
(test-eliminate-whitespace '(html) identity "<html>\n<p>Hey</p></html>" "<html><p>Hey</p></html>")
|
|
(test-eliminate-whitespace/exn '(html) not "<html>\n<p>Hey</p></html>" "not allowed to contain text")
|
|
(test-eliminate-whitespace/exn '(html) truer "<html>\n<p>Hey</p></html>" "not allowed to contain text")
|
|
|
|
(test-eliminate-whitespace '(html) identity "<html>\n<p>\n</p></html>" "<html><p>\n</p></html>")
|
|
(test-eliminate-whitespace '(html) not "<html>\n<p>\n</p></html>" "<html>\n<p /></html>")
|
|
(test-eliminate-whitespace '(html) truer "<html>\n<p>\n</p></html>" "<html><p /></html>")))
|
|
|
|
(local
|
|
[(define (test-validate-xexpr xe)
|
|
(test-not-false (format "~S" xe) (validate-xexpr xe)))
|
|
(define (test-validate-xexpr/exn xe v)
|
|
(test-exn (format "~S" xe)
|
|
(lambda (x)
|
|
(and (exn:invalid-xexpr? x)
|
|
(equal? (exn:invalid-xexpr-code x) v)))
|
|
(lambda ()
|
|
(validate-xexpr xe))))]
|
|
(test-suite
|
|
"validate-xexpr"
|
|
(test-validate-xexpr 64)
|
|
(test-validate-xexpr 'nbsp)
|
|
(test-validate-xexpr "string")
|
|
(test-validate-xexpr (make-pcdata #f #f "pcdata"))
|
|
(test-validate-xexpr (make-cdata #f #f "cdata"))
|
|
(test-validate-xexpr (make-comment "comment"))
|
|
(test-validate-xexpr (make-p-i #f #f 's1 "s2"))
|
|
(test-validate-xexpr '(br))
|
|
(test-validate-xexpr '(br ()))
|
|
(test-validate-xexpr '(a ([href "#"]) "string"))
|
|
|
|
(test-validate-xexpr/exn #f #f)
|
|
(test-validate-xexpr/exn 4 4)
|
|
(test-validate-xexpr/exn + +)
|
|
(test-validate-xexpr/exn '(a ([href foo]) bar) 'foo)
|
|
(test-validate-xexpr/exn '("foo" bar) '("foo" bar))))
|
|
|
|
; XXX correct-xexpr?
|
|
|
|
(test-suite
|
|
"permissive-xexprs"
|
|
(test-exn
|
|
"Non-permissive"
|
|
(lambda (exn)
|
|
(and (exn? exn)
|
|
(regexp-match #rx"not in permissive mode" (exn-message exn))))
|
|
(lambda ()
|
|
(xml->xexpr #f)))
|
|
|
|
(test-false
|
|
"Permissive"
|
|
(parameterize ([permissive-xexprs #t])
|
|
(xml->xexpr #f))))))
|
|
|
|
(local
|
|
[(define ((mk-test-param param) v istr ostr)
|
|
(test-equal? (format "~S" (list v istr))
|
|
(parameterize ([param v])
|
|
(with-output-to-string
|
|
(lambda ()
|
|
(write-xml (read-xml (open-input-string istr))))))
|
|
ostr))
|
|
(define test-empty-tag-shorthand (mk-test-param empty-tag-shorthand))
|
|
(define test-collapse-whitespace (mk-test-param collapse-whitespace))
|
|
(define test-read-comments (mk-test-param read-comments))]
|
|
(test-suite
|
|
"Parameters"
|
|
|
|
(test-suite
|
|
"empty-tag-shorthand"
|
|
(test-empty-tag-shorthand 'always "<html></html>" "<html />")
|
|
(test-empty-tag-shorthand 'always "<html>Hey</html>" "<html>Hey</html>")
|
|
(test-empty-tag-shorthand 'never "<html></html>" "<html></html>")
|
|
(test-empty-tag-shorthand 'never "<html>Hey</html>" "<html>Hey</html>")
|
|
(test-empty-tag-shorthand empty "<html></html>" "<html></html>")
|
|
(test-empty-tag-shorthand empty "<html>Hey</html>" "<html>Hey</html>")
|
|
(test-empty-tag-shorthand '(html) "<html></html>" "<html />")
|
|
(test-empty-tag-shorthand '(html) "<html>Hey</html>" "<html>Hey</html>")
|
|
(test-empty-tag-shorthand '(p) "<html></html>" "<html></html>")
|
|
(test-empty-tag-shorthand '(p) "<html>Hey</html>" "<html>Hey</html>"))
|
|
|
|
(test-equal? "html-empty-tags"
|
|
html-empty-tags
|
|
'(param meta link isindex input img hr frame col br basefont base area))
|
|
|
|
(test-suite
|
|
"collapse-whitespace"
|
|
(test-collapse-whitespace #t "<html>\n</html>" "<html> </html>")
|
|
(test-collapse-whitespace #t "<html>\t</html>" "<html> </html>")
|
|
(test-collapse-whitespace #t "<html> </html>" "<html> </html>")
|
|
(test-collapse-whitespace #t "<html><![CDATA[ ]]></html>" "<html><![CDATA[ ]]></html>")
|
|
(test-collapse-whitespace #t "<html><![CDATA[\n]]></html>" "<html><![CDATA[\n]]></html>")
|
|
(test-collapse-whitespace #t "<html><![CDATA[\t]]></html>" "<html><![CDATA[\t]]></html>")
|
|
(test-collapse-whitespace #f "<html>\n</html>" "<html>\n</html>"))
|
|
|
|
(test-suite
|
|
"read-comments"
|
|
(test-read-comments #f "<html><!-- Foo --></html>" "<html />")
|
|
(test-read-comments #t "<html><!-- Foo --></html>" "<html><!-- Foo --></html>"))
|
|
|
|
(local
|
|
[(define (test-xexpr-drop-empty-attributes v istr xe)
|
|
(test-equal? (format "~S" (list v istr))
|
|
(parameterize ([xexpr-drop-empty-attributes v])
|
|
(xml->xexpr (document-element (read-xml (open-input-string istr)))))
|
|
xe))]
|
|
(test-suite
|
|
"xexpr-drop-empty-attributes"
|
|
|
|
(test-xexpr-drop-empty-attributes #f "<html />" '(html ()))
|
|
(test-xexpr-drop-empty-attributes #t "<html />" '(html))
|
|
(test-xexpr-drop-empty-attributes #f "<html>Hey</html>" '(html () "Hey"))
|
|
(test-xexpr-drop-empty-attributes #t "<html>Hey</html>" '(html "Hey"))
|
|
(test-xexpr-drop-empty-attributes #f "<a href=\"#\">Hey</a>" '(a ([href "#"]) "Hey"))
|
|
(test-xexpr-drop-empty-attributes #t "<a href=\"#\">Hey</a>" '(a ([href "#"]) "Hey"))))))
|
|
|
|
(local
|
|
[(define example
|
|
`(dict (assoc-pair "first-key"
|
|
"just a string with some whitespace in it")
|
|
(assoc-pair "second-key"
|
|
(false))
|
|
(assoc-pair "third-key"
|
|
(dict ))
|
|
(assoc-pair "fourth-key"
|
|
(dict (assoc-pair "inner-key"
|
|
(real 3.432))))
|
|
(assoc-pair "fifth-key"
|
|
(array (integer 14)
|
|
"another string"
|
|
(true)))
|
|
(assoc-pair "sixth-key"
|
|
(array))))
|
|
(define example-str #<<END
|
|
<?xml version="1.0" encoding="UTF-8"?>
|
|
<!DOCTYPE plist SYSTEM "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
|
|
<plist version="0.9"><dict><key>first-key</key><string>just a string with some whitespace in it</string><key>second-key</key><false /><key>third-key</key><dict /><key>fourth-key</key><dict><key>inner-key</key><real>3.432</real></dict><key>fifth-key</key><array><integer>14</integer><string>another string</string><true /></array><key>sixth-key</key><array /></dict></plist>
|
|
END
|
|
)]
|
|
(test-suite
|
|
"PList Library"
|
|
|
|
(test-not-false
|
|
"plist-dict?"
|
|
(plist-dict?
|
|
example))
|
|
(test-false
|
|
"plist-dict?"
|
|
(plist-dict?
|
|
`(p "Hey")))
|
|
(test-false
|
|
"plist-dict?"
|
|
(plist-dict?
|
|
`(dict (p "Hey"))))
|
|
(test-false
|
|
"plist-dict?"
|
|
(plist-dict?
|
|
`(dict (assoc-pair "key" 2 3))))
|
|
(test-false
|
|
"plist-dict?"
|
|
(plist-dict?
|
|
`(dict (assoc-pair 1 2))))
|
|
(test-false
|
|
"plist-dict?"
|
|
(plist-dict?
|
|
`(dict (assoc-pair "key" #f))))
|
|
|
|
(test-equal? "read-plist"
|
|
(read-plist (open-input-string example-str))
|
|
example)
|
|
|
|
(test-equal? "write-plist"
|
|
(with-output-to-string
|
|
(lambda ()
|
|
(write-plist example (current-output-port))))
|
|
example-str)
|
|
|
|
(local [(define (test-plist-round-trip plist)
|
|
(define-values (in out) (make-pipe))
|
|
(write-plist plist out)
|
|
(close-output-port out)
|
|
(test-equal? (format "~S" plist) (read-plist in) plist))]
|
|
(test-plist-round-trip example))))))
|
|
|
|
(run-tests xml-tests)
|