test/xmlconf.lisp

   1 (defpackage xmlconf
   2   (:use :cl :runes)
   3   (:export #:run-all-tests))
   4 (in-package :xmlconf)
   5
   6 (defun get-attribute (element name)
   7   (rod-string (dom:get-attribute element name)))
   8
   9 (defparameter *bad-tests*
  10     '(;; TS14
  11       ;; http://lists.w3.org/Archives/Public/public-xml-testsuite/2002Mar/0001.html
  12       "ibm-valid-P28-ibm28v02.xml"
  13       "ibm-valid-P29-ibm29v01.xml"
  14       "ibm-valid-P29-ibm29v02.xml"))
  15
  16 (defun test-class (test)
  17   (cond
  18     ((not (and (let ((version (get-attribute test "RECOMMENDATION")))
  19                  (cond
  20                    ((or (equal version "") ;XXX
  21                         (equal version "XML1.0")
  22                         (equal version "NS1.0"))
  23                      (cond
  24                        ((equal (get-attribute test "NAMESPACE") "no")
  25                          (format t "~A: test applies to parsers without namespace support, skipping~%"
  26                                  (get-attribute test "URI"))
  27                          nil)
  28                        (t
  29                          t)))
  30                    ((equal version "XML1.1")
  31                      ;; not supported
  32                      nil)
  33                    (t
  34                      (warn "unrecognized RECOMMENDATION value: ~S" version)
  35                      nil)))
  36                (not (member (get-attribute test "ID") *bad-tests* :test 'equal))))
  37       nil)
  38     ((equal (get-attribute test "TYPE") "valid") :valid)
  39     ((equal (get-attribute test "TYPE") "invalid") :invalid)
  40     ((equal (get-attribute test "TYPE") "not-wf") :not-wf)
  41     (t nil)))
  42
  43 (defun test-pathnames (directory test)
  44   (let* ((sub-directory
  45           (loop
  46               for parent = test then (dom:parent-node parent)
  47               for base = (get-attribute parent "xml:base")
  48               until (plusp (length base))
  49               finally (return (merge-pathnames base directory))))
  50          (uri (get-attribute test "URI"))
  51          (output (get-attribute test "OUTPUT")))
  52     (values (merge-pathnames uri sub-directory)
  53             (when (plusp (length output))
  54               (merge-pathnames output sub-directory)))))
  55
  56 (defmethod serialize-document ((document t))
  57   (dom:map-document (cxml:make-octet-vector-sink :canonical 2)
  58                     document
  59                     :include-doctype :canonical-notations
  60                     :include-default-values t))
  61
  62 (defun file-contents (pathname)
  63   (with-open-file (s pathname :element-type '(unsigned-byte 8))
  64     (let ((result
  65            (make-array (file-length s) :element-type '(unsigned-byte 8))))
  66       (read-sequence result s )
  67       result)))
  68
  69 (defun dribble-tests (parser-fn directory)
  70   (let ((base (slot-value (asdf:find-system :cxml) 'asdf::relative-pathname)))
  71     (with-open-file (*standard-output*
  72                      (merge-pathnames "XMLCONF" base)
  73                      :direction :output
  74                      :external-format :iso-8859-1
  75                      :if-exists :supersede)
  76       (run-all-tests parser-fn directory))))
  77
  78 (defvar *parser-fn* 'sax-test)
  79
  80 (defun sax-test (filename handler &rest args)
  81   (apply #'cxml:parse-file filename handler :recode nil args))
  82
  83 (defun klacks-test (filename handler &rest args)
  84   (klacks:with-open-source
  85       (s (apply #'cxml:make-source (pathname filename) args))
  86     (klacks:serialize-source s handler)))
  87
  88 (defun run-all-tests (parser-fn directory)
  89   (let* ((*parser-fn* parser-fn)
  90          (pathname (merge-pathnames "xmlconf.xml" directory))
  91          (builder (rune-dom:make-dom-builder))
  92          (xmlconf (cxml:parse-file pathname builder :recode nil))
  93          (ntried 0)
  94          (nfailed 0)
  95          (nskipped 0)
  96          ;; XXX someone found it funny to include invalid URIs in the
  97          ;; test suite.  And no, in "invalid" not "not-wf".
  98          (puri:*strict-parse* nil))
  99     (dom:do-node-list (test (dom:get-elements-by-tag-name xmlconf "TEST"))
 100       (let ((description
 101              (apply #'concatenate
 102                     'string
 103                     (map 'list
 104                       (lambda (child)
 105                         (if (dom:text-node-p child)
 106                             (rod-string (dom:data child))
 107                             ""))
 108                       (dom:child-nodes test))))
 109             (class (test-class test)))
 110         (cond
 111           (class
 112             (incf ntried)
 113             (multiple-value-bind (pathname output)
 114                 (test-pathnames directory test)
 115               (princ (enough-namestring pathname directory))
 116               (unless (probe-file pathname)
 117                 (error "file not found: ~A" pathname))
 118               (with-simple-restart (skip-test "Skip this test")
 119                 (unless (run-test class pathname output description)
 120                   (incf nfailed))
 121                 (fresh-line))))
 122           (t
 123             (incf nskipped)))))
 124     (format t "~&~D/~D tests failed; ~D test~:P were skipped"
 125             nfailed ntried nskipped)))
 126
 127 (defmethod run-test :around (class pathname output description &rest args)
 128   (declare (ignore class pathname output args))
 129   (handler-case
 130       (call-next-method)
 131     (serious-condition (c)
 132       (format t " FAILED:~%  ~A~%[~A]~%" c description)
 133       nil)))
 134
 135 (defmethod run-test ((class null) pathname output description &rest args)
 136   (declare (ignore description))
 137   (let ((document (apply *parser-fn*
 138                          pathname
 139                          (rune-dom:make-dom-builder)
 140                          args)))
 141     ;; If we got here, parsing worked.  Let's try to serialize the same
 142     ;; document.  (We do the same thing in canonical mode below to check the
 143     ;; content model of the output, but that doesn't even catch obvious
 144     ;; errors in DTD serialization, so even a simple here is an
 145     ;; improvement.)
 146     (apply *parser-fn* pathname (cxml:make-rod-sink) args)
 147     (cond
 148       ((null output)
 149         (format t " input"))
 150       ((equalp (file-contents output) (serialize-document document))
 151         (format t " input/output"))
 152       (t
 153         (let ((error-output (make-pathname :type "error" :defaults output)))
 154           (with-open-file (s error-output
 155                            :element-type '(unsigned-byte 8)
 156                            :direction :output
 157                            :if-exists :supersede)
 158             (write-sequence (serialize-document document) s))
 159           (error "well-formed, but output ~S not the expected ~S~%"
 160                  error-output output))))
 161     t))
 162
 163 (defmethod run-test
 164     ((class (eql :valid)) pathname output description &rest args)
 165   (assert (null args))
 166   (and (progn
 167          (format t " [not validating:]")
 168          (run-test nil pathname output description :validate nil))
 169        (progn
 170          (format t " [validating:]")
 171          (run-test nil pathname output description :validate t))))
 172
 173 (defmethod run-test
 174     ((class (eql :invalid)) pathname output description &rest args)
 175   (assert (null args))
 176   (and (progn
 177          (format t " [not validating:]")
 178          (run-test nil pathname output description :validate nil))
 179        (handler-case
 180            (progn
 181              (format t " [validating:]")
 182              (funcall *parser-fn*
 183                       pathname
 184                       (rune-dom:make-dom-builder)
 185                       :validate t)
 186              (error "validity error not detected")
 187              nil)
 188          (cxml:validity-error ()
 189            (format t " invalid")
 190            t))))
 191
 192 (defmethod run-test
 193     ((class (eql :not-wf)) pathname output description &rest args)
 194   (assert (null args))
 195   (handler-case
 196       (progn
 197          (format t " [not validating:]")
 198         (funcall *parser-fn*
 199                  pathname
 200                  (rune-dom:make-dom-builder)
 201                  :validate nil)
 202         (error "well-formedness violation not detected")
 203       nil)
 204     #+fixme-stp-test
 205     (error ()
 206       (format t " unexpected-error")
 207       t)
 208     (cxml:well-formedness-violation ()
 209       (format t " not-wf")
 210       t))
 211   (handler-case
 212       (progn
 213         (format t " [validating:]")
 214         (funcall *parser-fn*
 215                  pathname
 216                  (rune-dom:make-dom-builder)
 217                  :validate t)
 218         (error "well-formedness violation not detected")
 219       nil)
 220     #+fixme-stp-test
 221     (error ()
 222       (format t " unexpected-error")
 223       t)
 224     (cxml:well-formedness-violation ()
 225       (format t " not-wf")
 226       t)
 227     (cxml:validity-error ()
 228       ;; das erlauben wir mal auch, denn valide => wf
 229       (format t " invalid")
 230       t)))
 231
 232 #+(or)
 233 (xmlconf::run-all-tests 'xmlconf::sax-test
 234                         "/home/david/2001/XML-Test-Suite/xmlconf/")
 235
 236 #+(or)
 237 (xmlconf::run-all-tests 'xmlconf::klacks-test
 238                         "/home/david/2001/XML-Test-Suite/xmlconf/")