[cxml-cvs] CVS update: cxml/test/domtest.lisp cxml/test/xmlconf.lisp

[David Lichteblau]

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/")