Initial revision

2005-03-13 18:02:10 +00:00
commit d6ca7664f4
81 changed files with 19663 additions and 0 deletions
--- a/test/xmlconf.lisp
+++ b/test/xmlconf.lisp
@ -0,0 +1,104 @@
+(defpackage xmlconf
+  (:use :cl :runes)
+  (:export #:run-all-tests))
+(in-package :xmlconf)
+
+(defun get-attribute (element name)
+  (rod-string (dom:get-attribute element name)))
+
+(defun relevant-test-p (test)
+  (and (equal (get-attribute test "TYPE") "valid")
+       (let ((version (get-attribute test "RECOMMENDATION")))
+         (cond
+           ((or (equal version "")      ;XXX
+                (equal version "XML1.0"))
+             (cond
+               ((equal (get-attribute test "NAMESPACE") "no")
+                 (format t "~A: test applies to parsers without namespace support, skipping~%"
+                       (get-attribute test "URI"))
+                 nil)
+               (t
+                 t)))
+           ((equal version "XML1.1")
+             ;; not supported
+             nil)
+           (t
+             (warn "unrecognized RECOMMENDATION value: ~S" version)
+             nil)))))
+
+(defun test-pathnames (directory test)
+  (let* ((sub-directory
+          (loop
+              for parent = test then (dom:parent-node parent)
+              for base = (get-attribute parent "xml:base")
+              until (plusp (length base))
+              finally (return (merge-pathnames base directory))))
+         (uri (get-attribute test "URI"))
+         (output (get-attribute test "OUTPUT")))
+    (values (merge-pathnames uri sub-directory)
+            (when (plusp (length output))
+              (merge-pathnames output sub-directory)))))
+
+(defun serialize-document (document)
+  (map 'vector #'char-code
+       (with-output-to-string (s)
+         (xml:unparse-document document s))))
+
+(defun file-contents (pathname)
+  (with-open-file (s pathname)
+    (let ((result
+           (make-array (file-length s) :element-type '(unsigned-byte 8))))
+      (read-sequence result s )
+      result)))
+
+(defun run-all-tests (directory)
+  (let* ((pathname (merge-pathnames "xmlconf.xml" directory))
+         (builder (dom:make-dom-builder))
+         (xmlconf (xml:parse-file pathname builder))
+         (ntried 0)
+         (nfailed 0)
+         (nskipped 0))
+    (dom:do-node-list (test (dom:get-elements-by-tag-name xmlconf "TEST"))
+      (cond
+        ((relevant-test-p test)
+          (incf ntried)
+          (multiple-value-bind (pathname output)
+              (test-pathnames directory test)
+            (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)
+                      (let ((document
+                             (xml:parse-file pathname (dom:make-dom-builder))))
+                        (cond
+                          ((null output)
+                            (format t " ok (output not checked)~%"))
+                          ((equalp (file-contents output)
+                                   (serialize-document document))
+                            (format t " ok~%"))
+                          (t
+                            (let ((error-output
+                                   (make-pathname :type "error" :defaults output)))
+                              (with-open-file (s error-output
+                                               :direction :output
+                                               :if-exists :supersede)
+                                (write-sequence (serialize-document document) s))
+                              (error "well-formed, but output ~S not the expected ~S~%"
+                                     error-output output)))))))
+                ((and serious-condition (not excl:interrupt-signal)) (c)
+                  (incf nfailed)
+                  (format t " FAILED:~%  ~A~%[~A]~%"
+                          c
+                          (rod-string
+                           (dom:data
+                            (dom:item (dom:child-nodes test) 0)))))))))
+        (t
+          (incf nskipped))))
+    (format t "~&~D/~D tests failed; ~D test~:P were skipped"
+            nfailed ntried nskipped)))
+
+#+(or)
+(xmlconf::run-all-tests "/mnt/debian/space/xmlconf/")