105 lines
4.0 KiB
Common Lisp
105 lines
4.0 KiB
Common Lisp
(defpackage xmlconf
|
|
(:use :cl :runes)
|
|
(:export #:run-all-tests))
|
|
(in-package :xmlconf)
|
|
|
|
(defun get-attribute (element name)
|
|
(rod-string (dom:get-attribute element name)))
|
|
|
|
(defun relevant-test-p (test)
|
|
(and (equal (get-attribute test "TYPE") "valid")
|
|
(let ((version (get-attribute test "RECOMMENDATION")))
|
|
(cond
|
|
((or (equal version "") ;XXX
|
|
(equal version "XML1.0"))
|
|
(cond
|
|
((equal (get-attribute test "NAMESPACE") "no")
|
|
(format t "~A: test applies to parsers without namespace support, skipping~%"
|
|
(get-attribute test "URI"))
|
|
nil)
|
|
(t
|
|
t)))
|
|
((equal version "XML1.1")
|
|
;; not supported
|
|
nil)
|
|
(t
|
|
(warn "unrecognized RECOMMENDATION value: ~S" version)
|
|
nil)))))
|
|
|
|
(defun test-pathnames (directory test)
|
|
(let* ((sub-directory
|
|
(loop
|
|
for parent = test then (dom:parent-node parent)
|
|
for base = (get-attribute parent "xml:base")
|
|
until (plusp (length base))
|
|
finally (return (merge-pathnames base directory))))
|
|
(uri (get-attribute test "URI"))
|
|
(output (get-attribute test "OUTPUT")))
|
|
(values (merge-pathnames uri sub-directory)
|
|
(when (plusp (length output))
|
|
(merge-pathnames output sub-directory)))))
|
|
|
|
(defun serialize-document (document)
|
|
(map 'vector #'char-code
|
|
(with-output-to-string (s)
|
|
(xml:unparse-document document s))))
|
|
|
|
(defun file-contents (pathname)
|
|
(with-open-file (s pathname)
|
|
(let ((result
|
|
(make-array (file-length s) :element-type '(unsigned-byte 8))))
|
|
(read-sequence result s )
|
|
result)))
|
|
|
|
(defun run-all-tests (directory)
|
|
(let* ((pathname (merge-pathnames "xmlconf.xml" directory))
|
|
(builder (dom:make-dom-builder))
|
|
(xmlconf (xml:parse-file pathname builder))
|
|
(ntried 0)
|
|
(nfailed 0)
|
|
(nskipped 0))
|
|
(dom:do-node-list (test (dom:get-elements-by-tag-name xmlconf "TEST"))
|
|
(cond
|
|
((relevant-test-p test)
|
|
(incf ntried)
|
|
(multiple-value-bind (pathname output)
|
|
(test-pathnames directory test)
|
|
(princ pathname)
|
|
(unless (probe-file pathname)
|
|
(error "file not found: ~A" pathname))
|
|
(with-simple-restart (skip-test "Skip this test")
|
|
(handler-case
|
|
(progn
|
|
(mp:with-timeout (60)
|
|
(let ((document
|
|
(xml:parse-file pathname (dom:make-dom-builder))))
|
|
(cond
|
|
((null output)
|
|
(format t " ok (output not checked)~%"))
|
|
((equalp (file-contents output)
|
|
(serialize-document document))
|
|
(format t " ok~%"))
|
|
(t
|
|
(let ((error-output
|
|
(make-pathname :type "error" :defaults output)))
|
|
(with-open-file (s error-output
|
|
:direction :output
|
|
:if-exists :supersede)
|
|
(write-sequence (serialize-document document) s))
|
|
(error "well-formed, but output ~S not the expected ~S~%"
|
|
error-output output)))))))
|
|
((and serious-condition (not excl:interrupt-signal)) (c)
|
|
(incf nfailed)
|
|
(format t " FAILED:~% ~A~%[~A]~%"
|
|
c
|
|
(rod-string
|
|
(dom:data
|
|
(dom:item (dom:child-nodes test) 0)))))))))
|
|
(t
|
|
(incf nskipped))))
|
|
(format t "~&~D/~D tests failed; ~D test~:P were skipped"
|
|
nfailed ntried nskipped)))
|
|
|
|
#+(or)
|
|
(xmlconf::run-all-tests "/mnt/debian/space/xmlconf/")
|