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

[David Lichteblau]

Update of /project/cxml/cvsroot/cxml/test
In directory common-lisp.net:/tmp/cvs-serv22921/test

Modified Files:
	domtest.lisp 
Log Message:
DOM 2 Core.  Ungetestet, aber die 1er tests laufen wieder, daher rein damit.

Date: Sun Dec  4 19:44:00 2005
Author: dlichteblau

Index: cxml/test/domtest.lisp
diff -u cxml/test/domtest.lisp:1.4 cxml/test/domtest.lisp:1.5
--- cxml/test/domtest.lisp:1.4	Sat Nov 26 23:55:23 2005
+++ cxml/test/domtest.lisp	Sun Dec  4 19:44:00 2005
@@ -142,11 +142,14 @@
                (c = (elt str i))
                :until (runes:rune= c #.(runes:char-rune #\")))
             (if (runes:rune= c #.(runes:char-rune #\\))
-                (ecase (progn
+                (let ((frob
+		       (progn
                          (incf i)
-                         (elt str i))
-                  ;; ...
-                  (#/n (vector-push-extend #/newline v (length v))))
+                         (elt str i))))
+		  (ecase frob
+		    ;; ...
+		    (#/n (vector-push-extend #/newline v (length v)))
+		    ((#/\\ #/\") (vector-push-extend #/\\ v (length v)))))
                 (vector-push-extend c v (length v))))
         (coerce v 'runes::simple-rod)))
     (t
@@ -163,13 +166,14 @@
 
 ;;;; dom1-interfaces.xml auslesen
 
-(defvar *methods* '())
-(defvar *fields* '())
+(defparameter *methods* '())
+(defparameter *fields* '())
 
 (declaim (special *directory*))
+(declaim (special *files-directory*))
 
-(defun read-members ()
-  (let* ((pathname (merge-pathnames "patches/dom1-interfaces.xml" *directory*))
+(defun read-members (&optional (directory *directory*))
+  (let* ((pathname (merge-pathnames "build/dom2-interfaces.xml" directory))
          (builder (dom:make-dom-builder))
          (library (dom:document-element (cxml:parse-file pathname builder)))
          (methods '())
@@ -554,8 +558,15 @@
 (defun assert-have-implementation-attribute (element)
   (let ((attribute (runes:rod-string (dom:get-attribute element "name"))))
     (string-case attribute
+      ;; fixme: expandEntityReferences sollten wir auch mal anschalten, wo
+      ;; wir uns schon die muehe machen...
       ("validating"
         (setf cxml::*validate* t))
+      ("namespaceAware"
+	;; ???  dom 2 ohne namespace-support gibt's doch gar nicht,
+	;; ausser vielleicht in html-only implementationen, und dann sollen
+	;; sie halt auf hasFeature "XML" testen.
+        )
       (t
         (format t "~&implementationAttribute ~A not supported, skipping test~%"
                 attribute)
@@ -606,12 +617,9 @@
 (defun load-file (name &optional will-be-modified-p)
   (declare (ignore will-be-modified-p))
   (setf name (runes:rod-string name))
-  (let* ((directory (merge-pathnames "tests/level1/core/files/" *directory*))
-         (document
-          (cxml:parse-file
-           (make-pathname :name name :type "xml" :defaults directory)
-           (dom:make-dom-builder))))
-    document))
+  (cxml:parse-file
+   (make-pathname :name name :type "xml" :defaults *files-directory*)
+   (dom:make-dom-builder)))
 
 (defparameter *bad-tests*
     '("hc_elementnormalize2.xml"
@@ -628,39 +636,57 @@
 
 (defun run-all-tests (*directory* &optional verbose)
   (let* ((cxml::*redefinition-warning* nil)
-         (test-directory (merge-pathnames "tests/level1/core/" *directory*))
-         (all-tests (merge-pathnames "alltests.xml" test-directory))
-         (builder (dom:make-dom-builder))
-         (suite (dom:document-element (cxml:parse-file all-tests builder)))
          (n 0)
          (i 0)
          (ntried 0)
          (nfailed 0))
-    (do-child-elements (member suite)
-      (unless
-          (or (equal (dom:tag-name member) "metadata")
-              (member (runes:rod-string (dom:get-attribute member "href"))
-                      *bad-tests*
-                      :test 'equal))
-        (incf n)))
-    (do-child-elements (member suite)
-      (let ((href (runes:rod-string (dom:get-attribute member "href"))))
-        (unless (or (runes:rod= (dom:tag-name member) #"metadata")
-                    (member href *bad-tests* :test 'equal))
-          (format t "~&~D/~D ~A~%" i n href)
-          (let ((lisp (slurp-test (merge-pathnames href test-directory))))
-            (when verbose
-              (print lisp))
-            (when lisp
-              (incf ntried)
-              (with-simple-restart (skip-test "Skip this test")
-                (handler-case
-                    (let ((cxml::*validate* nil))
-                      (funcall (compile nil lisp)))
-                  (serious-condition (c)
-                    (incf nfailed)
-                    (warn "test failed: ~A" c))))))
-          (incf i))))
+    (flet ((parse (test-directory)
+	     (let* ((all-tests (merge-pathnames "alltests.xml" test-directory))
+		    (builder (dom:make-dom-builder))
+		    (suite (dom:document-element
+			    (cxml:parse-file all-tests builder)))
+		    (*files-directory*
+		     (merge-pathnames "files/" test-directory)))
+	       (do-child-elements (member suite)
+		 (unless
+		     (or (equal (dom:tag-name member) "metadata")
+			 (member (runes:rod-string
+				  (dom:get-attribute member "href"))
+				 *bad-tests*
+				 :test 'equal))
+		   (incf n)))
+	       suite))
+	   (run (test-directory suite)
+	     (print test-directory)
+	     (let ((*files-directory*
+		    (merge-pathnames "files/" test-directory)))
+	       (do-child-elements (member suite)
+		 (let ((href (runes:rod-string
+			      (dom:get-attribute member "href"))))
+		   (unless (or (runes:rod= (dom:tag-name member) #"metadata")
+			       (member href *bad-tests* :test 'equal))
+		     (format t "~&~D/~D ~A~%" i n href)
+		     (let ((lisp (slurp-test
+				  (merge-pathnames href test-directory))))
+		       (when verbose
+			 (print lisp))
+		       (when lisp
+			 (incf ntried)
+			 (with-simple-restart (skip-test "Skip this test")
+			   (handler-case
+			       (let ((cxml::*validate* nil))
+				 (funcall (compile nil lisp)))
+			     (serious-condition (c)
+			       (incf nfailed)
+			       (warn "test failed: ~A" c))))))
+		     (incf i)))))))
+      (let* ((d1 (merge-pathnames "tests/level1/core/" *directory*))
+	     (d2 (merge-pathnames "tests/level2/core/" *directory*))
+	     (suite1 (parse d1))
+	     (suite2 (parse d2)))
+	(run d1 suite1)
+	#+(or)
+	(run d2 suite2)))
     (format t "~&~D/~D tests failed; ~D test~:P were skipped"
             nfailed ntried (- n ntried))))