OSCL/CXML
2
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

update DOM test suite driver

Browse Source
This commit is contained in:
dlichteblau
2005-04-06 21:14:41 +00:00
parent 8806c62695
commit 007b129d05
2 changed files with 1011 additions and 89 deletions
Download Patch File Download Diff File Expand all files Collapse all files

980
README.html
View File

File diff suppressed because it is too large Load Diff

66
test/domtest.lisp
View File

@ -1,5 +1,5 @@
(defpackage :domtest (defpackage :domtest
(:use :cl :xml) (:use :cl :cxml)
(:export #:run-all-tests)) (:export #:run-all-tests))
(defpackage :domtest-tests (defpackage :domtest-tests
(:use)) (:use))
@ -117,7 +117,10 @@
(write-char #\- out)))))) (write-char #\- out))))))
(defun intern-dom (name) (defun intern-dom (name)
(intern (replace-studly-caps name) :dom)) (setf name (replace-studly-caps name))
(when (eq :foo :FOO)
(setf name (string-upcase name)))
(intern name :dom))
(defun child-elements (element) (defun child-elements (element)
(map-child-elements 'list #'identity element)) (map-child-elements 'list #'identity element))
@ -167,7 +170,7 @@
(defun read-members () (defun read-members ()
(let* ((pathname (merge-pathnames "patches/dom1-interfaces.xml" *directory*)) (let* ((pathname (merge-pathnames "patches/dom1-interfaces.xml" *directory*))
(builder (dom:make-dom-builder)) (builder (dom:make-dom-builder))
(library (dom:document-element (xml:parse-file pathname builder))) (library (dom:document-element (cxml:parse-file pathname builder)))
(methods '()) (methods '())
(fields '())) (fields '()))
(do-child-elements (interface library :name "interface") (do-child-elements (interface library :name "interface")
@ -189,6 +192,7 @@
(defun translate-condition (element) (defun translate-condition (element)
(string-case (tag-name element) (string-case (tag-name element)
("equals" (translate-equals element)) ("equals" (translate-equals element))
("notEquals" (translate-not-equals element))
("contentType" (translate-content-type element)) ("contentType" (translate-content-type element))
("hasFeature" (translate-has-feature element)) ("hasFeature" (translate-has-feature element))
("implementationAttribute" (assert-have-implementation-attribute element)) ("implementationAttribute" (assert-have-implementation-attribute element))
@ -197,6 +201,7 @@
("notNull" (translate-not-null element)) ("notNull" (translate-not-null element))
("or" (translate-or element)) ("or" (translate-or element))
("same" (translate-same element)) ("same" (translate-same element))
("less" (translate-less element))
(t (error "unknown condition: ~A" element)))) (t (error "unknown condition: ~A" element))))
(defun equalsp (a b test) (defun equalsp (a b test)
@ -216,13 +221,20 @@
(defun translate-equals (element) (defun translate-equals (element)
(with-attributes (|actual| |expected| |ignoreCase|) element (with-attributes (|actual| |expected| |ignoreCase|) element
`(equalsp ,(%intern actual) `(equalsp ,(%intern |actual|)
,(parse-java-literal expected) ,(parse-java-literal |expected|)
',(if (parse-java-literal |ignoreCase|) '%equal '%equal)))) ',(if (parse-java-literal |ignoreCase|) '%equal '%equal))))
(defun translate-not-equals (element)
`(not ,(translate-equals element)))
(defun translate-same (element) (defun translate-same (element)
(with-attributes (|actual| |expected|) element (with-attributes (|actual| |expected|) element
`(eql ,(%intern actual) ,(parse-java-literal expected)))) `(eql ,(%intern |actual|) ,(parse-java-literal |expected|))))
(defun translate-less (element)
(with-attributes (|actual| |expected|) element
`(< ,(%intern |actual|) ,(parse-java-literal |expected|))))
(defun translate-or (element) (defun translate-or (element)
`(or ,@(map-child-elements 'list #'translate-condition element))) `(or ,@(map-child-elements 'list #'translate-condition element)))
@ -257,6 +269,13 @@
(with-attributes (|type|) element (with-attributes (|type|) element
`(equal ,|type| "text/xml"))) `(equal ,|type| "text/xml")))
#-allegro
(defun translate-uri-equals (element)
(declare (ignore element))
(warn "oops, assert-uri-equals needs Franz' URI package")
(throw 'give-up nil))
#+allegro
(defun translate-uri-equals (element) (defun translate-uri-equals (element)
(with-attributes (with-attributes
(|actual| (|actual|
@ -307,6 +326,7 @@
("assertTrue" (translate-assert-true element)) ("assertTrue" (translate-assert-true element))
("assertFalse" (translate-assert-false element)) ("assertFalse" (translate-assert-false element))
("assertURIEquals" (translate-assert-uri-equals element)) ("assertURIEquals" (translate-assert-uri-equals element))
("assign" (translate-assign element))
("for-each" (translate-for-each element)) ("for-each" (translate-for-each element))
("fail" (translate-fail element)) ("fail" (translate-fail element))
("hasFeature" (translate-has-feature element)) ("hasFeature" (translate-has-feature element))
@ -327,6 +347,10 @@
`(,fn ,(parse-java-literal |op1|) `(,fn ,(parse-java-literal |op1|)
,(parse-java-literal |op2|))))) ,(parse-java-literal |op2|)))))
(defun translate-assign (element)
(with-attributes (|var| |value|) element
(maybe-setf (%intern |var|) (parse-java-literal |value|))))
(defun translate-unary-assignment (fn element) (defun translate-unary-assignment (fn element)
(with-attributes (|var| |value|) element (with-attributes (|var| |value|) element
(maybe-setf (%intern |var|) (maybe-setf (%intern |var|)
@ -529,6 +553,8 @@
(defun assert-have-implementation-attribute (element) (defun assert-have-implementation-attribute (element)
(let ((attribute (runes:rod-string (dom:get-attribute element "name")))) (let ((attribute (runes:rod-string (dom:get-attribute element "name"))))
(string-case attribute (string-case attribute
("validating"
(setf cxml::*validate* t))
(t (t
(format t "~&implementationAttribute ~A not supported, skipping test~%" (format t "~&implementationAttribute ~A not supported, skipping test~%"
attribute) attribute)
@ -536,14 +562,15 @@
(defun slurp-test (pathname) (defun slurp-test (pathname)
(unless *fields* (unless *fields*
(multiple-value-setq (*methods* *fields*) (read-members *directory*))) (multiple-value-setq (*methods* *fields*) (read-members)))
(catch 'give-up (catch 'give-up
(let* ((builder (dom:make-dom-builder)) (let* ((builder (dom:make-dom-builder))
(test (dom:document-element (xml:parse-file pathname builder))) (cxml::*validate* nil) ;dom1.dtd is buggy
(test (dom:document-element (cxml:parse-file pathname builder)))
title title
(bindings '()) (bindings '())
(code '())) (code '()))
(declare (ignore title)) (declare (ignorable title))
(do-child-elements (e test) (do-child-elements (e test)
(string-case (tag-name e) (string-case (tag-name e)
("metadata" ("metadata"
@ -580,33 +607,36 @@
(setf name (runes:rod-string name)) (setf name (runes:rod-string name))
(let* ((directory (merge-pathnames "tests/level1/core/files/" *directory*)) (let* ((directory (merge-pathnames "tests/level1/core/files/" *directory*))
(document (document
(xml:parse-file (cxml:parse-file
(make-pathname :name name :type "xml" :defaults directory) (make-pathname :name name :type "xml" :defaults directory)
(dom:make-dom-builder)))) (dom:make-dom-builder))))
document)) document))
(defparameter *bad-tests* (defparameter *bad-tests*
'("hc_elementnormalize2.xml" "hc_nodereplacechildnewchildexists.xml")) '("hc_nodereplacechildnewchildexists.xml"
"characterdatadeletedatanomodificationallowederr.xml"))
(defun run-all-tests (*directory* &optional verbose) (defun run-all-tests (*directory* &optional verbose)
(let* ((xml::*redefinition-warning* nil) (let* ((cxml::*redefinition-warning* nil)
(test-directory (merge-pathnames "tests/level1/core/" *directory*)) (test-directory (merge-pathnames "tests/level1/core/" *directory*))
(all-tests (merge-pathnames "alltests.xml" test-directory)) (all-tests (merge-pathnames "alltests.xml" test-directory))
(builder (dom:make-dom-builder)) (builder (dom:make-dom-builder))
(suite (dom:document-element (xml:parse-file all-tests builder))) (suite (dom:document-element (cxml:parse-file all-tests builder)))
(n 0) (n 0)
(i 0) (i 0)
(ntried 0) (ntried 0)
(nfailed 0)) (nfailed 0))
(do-child-elements (member suite) (do-child-elements (member suite)
(unless (unless
(or (equal (dom:tag-name member) "metadata")
(member (runes:rod-string (dom:get-attribute member "href")) (member (runes:rod-string (dom:get-attribute member "href"))
*bad-tests* *bad-tests*
:test 'equal) :test 'equal))
(incf n))) (incf n)))
(do-child-elements (member suite) (do-child-elements (member suite)
(let ((href (runes:rod-string (dom:get-attribute member "href")))) (let ((href (runes:rod-string (dom:get-attribute member "href"))))
(unless (member href *bad-tests* :test 'equal) (unless (or (equal (dom:tag-name member) "metadata")
(member href *bad-tests* :test 'equal))
(format t "~&~D/~D ~A~%" i n href) (format t "~&~D/~D ~A~%" i n href)
(let ((lisp (slurp-test (merge-pathnames href test-directory)))) (let ((lisp (slurp-test (merge-pathnames href test-directory))))
(when verbose (when verbose
@ -615,7 +645,8 @@
(incf ntried) (incf ntried)
(with-simple-restart (skip-test "Skip this test") (with-simple-restart (skip-test "Skip this test")
(handler-case (handler-case
(funcall (compile nil lisp)) (let ((cxml::*validate* nil))
(funcall (compile nil lisp)))
(serious-condition (c) (serious-condition (c)
(incf nfailed) (incf nfailed)
(warn "test failed: ~A" c)))))) (warn "test failed: ~A" c))))))
@ -625,7 +656,8 @@
(defun run-test (*directory* href) (defun run-test (*directory* href)
(let* ((test-directory (merge-pathnames "tests/level1/core/" *directory*)) (let* ((test-directory (merge-pathnames "tests/level1/core/" *directory*))
(lisp (slurp-test (merge-pathnames href test-directory)))) (lisp (slurp-test (merge-pathnames href test-directory)))
(cxml::*validate* nil))
(print lisp) (print lisp)
(when lisp (when lisp
(funcall (compile nil lisp))))) (funcall (compile nil lisp)))))