Commit edded72c authored by david's avatar david

Revision: cxml--devel--1.0--patch-15

Archive: david@knowledgetools.de--cxml
Creator: David Lichteblau <david@knowledgetools.de>
Date: Tue Jan 13 21:13:28 CET 2004
Standard-date: 2004-01-13 20:13:28 GMT
Modified-files: xmlconf.lisp
New-patches: david@knowledgetools.de--cxml/cxml--devel--1.0--patch-15
Summary: run only tests for namespace-aware XML-1.0 parsers

run only tests for namespace-aware XML-1.0 parsers
parent dadf08a0
......@@ -3,21 +3,47 @@
(:alias (:string-dom :dom)))
(in-package :xmlconf)
(defun relevant-test-p (test)
(and (equal (dom:get-attribute test "TYPE") "valid")
(let ((version (dom:get-attribute test "RECOMMENDATION")))
(cond
((equal version "XML1.0")
(cond
((equal (dom:get-attribute test "NAMESPACE") "no")
(warn "~A: test applies to parsers without namespace support, skipping"
(dom:get-attribute test "URI"))
nil)
(t
t)))
((equal version "XML1.1")
;; not supported
nil)
(t
(warn "unrecognized RECOMMENDATION value: ~A" version)
nil)))))
(defun test-xml-conformance (directory)
(let ((xmlconf (xml:parse-file (merge-pathnames "xmlconf.xml" directory))))
(dolist (test (dom:get-elements-by-tag-name xmlconf "test"))
(when (equal (dom:get-attribute test "TYPE") "valid")
(let* ((base (dom:get-attribute (dom:parent-node test) "xml:base"))
(uri (dom:get-attribute test "URI")))
(unless base
(inspect test))
(princ uri)
(handler-case
(progn
(xml:parse-file
(merge-pathnames uri (merge-pathnames base directory)))
(format t " ok~%"))
(serious-condition (c)
(format t " FAILED:~% ~A~%[~A]~%"
c
(dom:data (car (dom:child-nodes test)))))))))))
(dolist (test (dom:get-elements-by-tag-name xmlconf "TEST"))
(when (relevant-test-p test)
(let* ((uri (dom:get-attribute test "URI"))
(base
(loop
for parent = test then (dom:parent-node parent)
for base = (dom:get-attribute parent "xml:base")
until base
finally (return base)))
(pathname (merge-pathnames uri (merge-pathnames base directory))))
(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)
(xml:parse-file pathname))
(format t " ok~%"))
((and serious-condition (not excl:interrupt-signal)) (c)
(format t " FAILED:~% ~A~%[~A]~%"
c
(dom:data (car (dom:child-nodes test))))))))))))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment