99 lines
2.8 KiB
Scheme
99 lines
2.8 KiB
Scheme
#lang scheme
|
|
(require schemeunit
|
|
schemeunit/base
|
|
schemeunit/test-case
|
|
schemeunit/check
|
|
schemeunit/test-suite
|
|
schemeunit/text-ui
|
|
xml
|
|
scheme/runtime-path)
|
|
(require/expose schemeunit/test-suite
|
|
(current-seed))
|
|
|
|
(define (validate-xml? xml)
|
|
(error 'validate-xml? "Not implemented"))
|
|
(define (well-formed-xml? xml)
|
|
(error 'well-formed-xml? "Not implemented"))
|
|
|
|
(define (read-xml/file f)
|
|
(with-input-from-file f
|
|
(lambda () (read-xml))))
|
|
(define (dir->test-suite d name path->test-case)
|
|
(make-schemeunit-test-suite
|
|
name
|
|
(lambda (fdown fup fhere seed)
|
|
(parameterize
|
|
([current-seed seed]
|
|
[current-test-case-around (test-suite-test-case-around fhere)]
|
|
[current-check-around (test-suite-check-around fhere)])
|
|
(for-each (lambda (p)
|
|
(define t (path->test-case (build-path d p)))
|
|
(if (schemeunit-test-suite? t)
|
|
(current-seed (apply-test-suite t fdown fup fhere (current-seed)))
|
|
t))
|
|
(filter (lambda (p)
|
|
(define ext (filename-extension p))
|
|
(and ext (bytes=? #"xml" ext)))
|
|
(directory-list d))))
|
|
(current-seed))
|
|
void
|
|
void))
|
|
|
|
(define (not-wf-dir->test-suite d)
|
|
(define (path->test-case f)
|
|
(test-not-false
|
|
(path->string f)
|
|
(with-handlers ([exn:xml? (lambda _ #t)])
|
|
(not (well-formed-xml? (read-xml/file f))))))
|
|
(test-suite
|
|
"Not Well-Formed"
|
|
(dir->test-suite
|
|
(build-path d "sa") "Stand-alone"
|
|
path->test-case)
|
|
(dir->test-suite
|
|
(build-path d "ext-sa") "External Stand-alone"
|
|
path->test-case)
|
|
(dir->test-suite
|
|
(build-path d "not-sa") "Not Stand-alone"
|
|
path->test-case)))
|
|
(define (invalid-dir->test-suite d)
|
|
(dir->test-suite
|
|
d "Invalid"
|
|
(lambda (f)
|
|
(test-false (path->string f)
|
|
(validate-xml? (read-xml/file f))))))
|
|
; XXX also check canonical xml
|
|
(define (valid-dir->test-suite d)
|
|
(define (path->test-case f)
|
|
(test-not-false (path->string f)
|
|
(validate-xml? (read-xml/file f))))
|
|
(test-suite
|
|
"Valid"
|
|
(dir->test-suite
|
|
(build-path d "sa") "Stand-alone"
|
|
path->test-case)
|
|
(dir->test-suite
|
|
(build-path d "ext-sa") "External Stand-alone"
|
|
path->test-case)
|
|
(dir->test-suite
|
|
(build-path d "not-sa") "Not Stand-alone"
|
|
path->test-case)))
|
|
|
|
(define (directory->test-suite d)
|
|
(test-suite
|
|
"James Clark's XML Test Cases"
|
|
|
|
(not-wf-dir->test-suite (build-path d "not-wf"))
|
|
(invalid-dir->test-suite (build-path d "invalid"))
|
|
(valid-dir->test-suite (build-path d "valid"))))
|
|
|
|
(define-runtime-path
|
|
clark-tests-dir
|
|
(list 'lib "xml/clark-tests" "tests"))
|
|
|
|
(define clark-tests
|
|
(directory->test-suite
|
|
clark-tests-dir))
|
|
|
|
(run-tests clark-tests)
|