Update of /project/cxml/cvsroot/cxml/test In directory common-lisp.net:/tmp/cvs-serv18680/test Modified Files: domtest.lisp xmlconf.lisp Log Message: run not-wf tests Date: Sat Nov 26 23:55:23 2005 Author: dlichteblau Index: cxml/test/domtest.lisp diff -u cxml/test/domtest.lisp:1.3 cxml/test/domtest.lisp:1.4 --- cxml/test/domtest.lisp:1.3 Sat Jun 25 15:56:57 2005 +++ cxml/test/domtest.lisp Sat Nov 26 23:55:23 2005 @@ -618,6 +618,14 @@ "hc_nodereplacechildnewchildexists.xml" "characterdatadeletedatanomodificationallowederr.xml")) +(defun dribble-tests (directory) + (let ((base (slot-value (asdf:find-system :cxml) 'asdf::relative-pathname))) + (with-open-file (*standard-output* + (merge-pathnames "DOMTEST" base) + :direction :output + :if-exists :supersede) + (run-all-tests directory)))) + (defun run-all-tests (*directory* &optional verbose) (let* ((cxml::*redefinition-warning* nil) (test-directory (merge-pathnames "tests/level1/core/" *directory*)) Index: cxml/test/xmlconf.lisp diff -u cxml/test/xmlconf.lisp:1.2 cxml/test/xmlconf.lisp:1.3 --- cxml/test/xmlconf.lisp:1.2 Wed Apr 20 21:58:03 2005 +++ cxml/test/xmlconf.lisp Sat Nov 26 23:55:23 2005 @@ -36,6 +36,7 @@ nil) ((equal (get-attribute test "TYPE") "valid") :valid) ((equal (get-attribute test "TYPE") "invalid") :invalid) + ((equal (get-attribute test "TYPE") "not-wf") :not-wf) (t nil))) (defun test-pathnames (directory test) @@ -63,6 +64,14 @@ (read-sequence result s ) result))) +(defun dribble-tests (directory) + (let ((base (slot-value (asdf:find-system :cxml) 'asdf::relative-pathname))) + (with-open-file (*standard-output* + (merge-pathnames "XMLCONF" base) + :direction :output + :if-exists :supersede) + (run-all-tests directory)))) + (defun run-all-tests (directory) (let* ((pathname (merge-pathnames "xmlconf.xml" directory)) (builder (dom:make-dom-builder)) @@ -75,7 +84,14 @@ (puri:*strict-parse* nil)) (dom:do-node-list (test (dom:get-elements-by-tag-name xmlconf "TEST")) (let ((description - (rod-string (dom:data (dom:item (dom:child-nodes test) 0)))) + (apply #'concatenate + 'string + (map 'list + (lambda (child) + (if (dom:text-node-p child) + (rod-string (dom:data child)) + "")) + (dom:child-nodes test)))) (class (test-class test))) (cond (class @@ -149,6 +165,21 @@ (cxml:validity-error () (format t " invalid") t)))) + +(defmethod run-test + ((class (eql :not-wf)) pathname output description &rest args) + (assert (null args)) + (handler-case + (progn + (format t " [not-wf?]") + (cxml:parse-file pathname (dom:make-dom-builder) :validate t) + nil) + (:no-error (n1l) + (error "well-formedness violation not detected") + n1l) + (serious-condition () + (format t " not-wf") + t))) #+(or) (xmlconf::run-all-tests "/mnt/debian/space/xmlconf/")