test.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
   2 ;;;
   3 ;;; Copyright (c) 2007 David Lichteblau. All rights reserved.
   4
   5 ;;; Redistribution and use in source and binary forms, with or without
   6 ;;; modification, are permitted provided that the following conditions
   7 ;;; are met:
   8 ;;;
   9 ;;;   * Redistributions of source code must retain the above copyright
  10 ;;;     notice, this list of conditions and the following disclaimer.
  11 ;;;
  12 ;;;   * Redistributions in binary form must reproduce the above
  13 ;;;     copyright notice, this list of conditions and the following
  14 ;;;     disclaimer in the documentation and/or other materials
  15 ;;;     provided with the distribution.
  16 ;;;
  17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  20 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  21 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  22 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  23 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  24 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  25 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  26 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  27 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  28
  29
  30 (in-package :cxml-rng)
  31
  32 (defun run-tests (&optional (p "/home/david/src/lisp/cxml-rng/spec-split/*")
  33                             (output-file "/home/david/src/lisp/cxml-rng/TEST"))
  34   (dribble output-file :if-exists :rename-and-delete)
  35   (let ((pass 0)
  36         (total 0)
  37         (*package* (find-package :cxml-rng))
  38         (*print-level* 3))
  39     (dolist (d (directory p))
  40       (let ((name (car (last (pathname-directory d)))))
  41         (when (parse-integer name :junk-allowed t)
  42           (let ((xml (directory (merge-pathnames "*.xml" d))))
  43             (incf total (1+ (length xml)))
  44             (multiple-value-bind (ok grammar) (test1 d)
  45               (cond
  46                 (ok
  47                  (incf pass (1+ (run-validation-tests name grammar xml))))
  48                 (t
  49                  (dolist (x xml)
  50                    (format t "~A-~D: FAIL: cannot run test~%"
  51                            name
  52                            (pathname-name x))))))))))
  53     (format t "Passed ~D/~D tests.~%" pass total))
  54   (dribble))
  55
  56 (defvar *compatibility-test-p* nil)
  57
  58 (defun run-dtd-tests
  59     (&optional (p "/home/david/src/lisp/cxml-rng/dtd-split/*")
  60                (q "/home/david/src/lisp/cxml-rng/DTDTEST"))
  61   (let ((*compatibility-test-p* t))
  62     (run-tests p q)))
  63
  64 (defun run-dtd-test
  65     (n &optional (p "/home/david/src/lisp/cxml-rng/dtd-split/*"))
  66   (let ((*break-on-signals* 'error))
  67     (run-test n p)))
  68
  69 (defun run-validation-test
  70     (m n &optional (p "/home/david/src/lisp/cxml-rng/spec-split/"))
  71   (let ((d (merge-pathnames (format nil "~3,'0D/" m) p))
  72         (*break-on-signals* 'error)
  73         (*debug* t)
  74         (*print-level* 3))
  75     (run-validation-tests m
  76                           (nth-value 1 (test1 d))
  77                           (list (let ((v (merge-pathnames
  78                                           (format nil "~A.v.xml" n)
  79                                           d)))
  80                                   (if (probe-file v)
  81                                       v
  82                                       (merge-pathnames
  83                                        (format nil "~A.i.xml" n)
  84                                        d)))))))
  85
  86 (defun run-validation-tests (name grammar tests)
  87   (let ((pass 0))
  88     (dolist (x tests)
  89       (format t "~A-~D: " name (pathname-name x))
  90       (flet ((doit ()
  91                (cxml:parse-file x (make-validator grammar))))
  92         (if (find #\v (pathname-name x))
  93             (handler-case
  94                 (progn
  95                   (doit)
  96                   (incf pass)
  97                   (format t "PASS~%"))
  98               (error (c)
  99                 (format t "FAIL: ~A~%" c)))
 100             (handler-case
 101                 (progn
 102                   (doit)
 103                   (format t "FAIL: didn't detect invalid document~%"))
 104               (dtd-compatibility-error (c)
 105                 (cond
 106                   (*compatibility-test-p*
 107                    (incf pass)
 108                    (format t "PASS: ~A~%" (type-of c)))
 109                   (t
 110                    (format t "FAIL: incorrect condition type: ~A~%" c))))
 111               (rng-error (c)
 112                 (cond
 113                   (*compatibility-test-p*
 114                    (format t "FAIL: incorrect condition type: ~A~%" c))
 115                   (t
 116                    (incf pass)
 117                    (format t "PASS: ~A~%" (type-of c)))))
 118               (error (c)
 119                 (format t "FAIL: incorrect condition type: ~A~%" c))))))
 120     pass))
 121
 122 (defun run-test (n &optional (p "/home/david/src/lisp/cxml-rng/spec-split/"))
 123   (test1 (merge-pathnames (format nil "~3,'0D/" n) p)))
 124
 125 (defun parse-test (n &optional (p "/home/david/src/lisp/cxml-rng/spec-split/"))
 126   (let* ((*debug* t)
 127          (d (merge-pathnames (format nil "~3,'0D/" n) p))
 128          (i (merge-pathnames "i.rng" d))
 129          (c (merge-pathnames "c.rng" d))
 130          (rng (if (probe-file c) c i)))
 131     (format t "~A: " (car (last (pathname-directory d))))
 132     (print rng)
 133     (parse-schema rng)))
 134
 135 (defun test1 (d)
 136   (let* ((i (merge-pathnames "i.rng" d))
 137          (c (merge-pathnames "c.rng" d)))
 138     (format t "~A: " (car (last (pathname-directory d))))
 139     (if (probe-file c)
 140         (handler-case
 141             (let ((grammar (parse-schema c)))
 142               (format t " PASS~%")
 143               (values t grammar))
 144           (error (c)
 145             (format t " FAIL: ~A~%" c)
 146             nil))
 147         (handler-case
 148             (progn
 149               (parse-schema i)
 150               (format t " FAIL: didn't detect invalid schema~%")
 151               nil)
 152           (dtd-compatibility-error (c)
 153             (cond
 154               (*compatibility-test-p*
 155                (format t " PASS: ~A~%" (type-of c))
 156                t)
 157               (t
 158                (format t " FAIL: incorrect condition type: ~A~%" c)
 159                nil)))
 160           (rng-error (c)
 161             (cond
 162               (*compatibility-test-p*
 163                (format t " FAIL: incorrect condition type: ~A~%" c)
 164                nil)
 165               (t
 166                (format t " PASS: ~A~%" (type-of c))
 167                t)))
 168           (error (c)
 169             (format t " FAIL: incorrect condition type: ~A~%" c)
 170             nil)))))
 171
 172 (defvar *test-xmllint*)
 173
 174 (defun run-nist-tests
 175     (*test-xmllint*
 176      &optional (p #p"/home/david/NISTSchemaTests/NISTXMLSchemaTestSuite.xml"))
 177   (dribble (if *test-xmllint*
 178                "/home/david/src/lisp/cxml-rng/NIST-xmllint"
 179                "/home/david/src/lisp/cxml-rng/NIST")
 180            :if-exists :rename-and-delete)
 181   (klacks:with-open-source (s (cxml:make-source p))
 182     (let ((total 0)
 183           (pass 0))
 184       (loop
 185          while (klacks:find-element s "Link")
 186          do
 187            (multiple-value-bind (n i)
 188                (run-nist-tests/link (klacks:get-attribute s "href") p)
 189              (incf total n)
 190              (incf pass i))
 191            (klacks:consume s))
 192       (format t "Passed ~D/~D tests.~%" pass total)))
 193   (dribble))
 194
 195 (defun run-nist-tests/link (href base)
 196   (klacks:with-open-source (r (cxml:make-source (merge-pathnames href base)))
 197     (let ((total 0)
 198           (pass 0))
 199       (let (schema)
 200         (loop
 201            (multiple-value-bind (key uri lname)
 202                (klacks:peek-next r)
 203              uri
 204              (unless key
 205                (return))
 206              (when (eq key :start-element)
 207                (cond
 208                  ((equal lname "Schema")
 209                   (incf total)
 210                   (let ((href (klacks:get-attribute r "href")))
 211                     (setf schema
 212                           (if (or (search "-enumeration-" href)
 213                                   (search "-whiteSpace-" href))
 214                               :ignore
 215                               (read-nist-grammar href base))))
 216                   (when schema
 217                     (incf total)))
 218                  ((equal lname "Instance")
 219                   (incf total)
 220                   (when (run-nist-test/Instance schema
 221                                                 (klacks:get-attribute r "href")
 222                                                 base)
 223                     (incf pass))))))))
 224       (values total pass))))
 225
 226 (defun run-nist-test/Instance (schema href base)
 227   (cond
 228     ((eq schema :ignore)
 229      (format t "PASS INSTANCE ~A: (ignored)~%" href)
 230      t)
 231     ((stringp schema)
 232      (assert *test-xmllint*)
 233      (let ((asdf::*VERBOSE-OUT* (make-string-output-stream)))
 234        (cond
 235          ((zerop (asdf:run-shell-command
 236                   "xmllint -relaxng ~A ~A"
 237                   schema
 238                   (namestring (merge-pathnames href base))))
 239           (format t "PASS INSTANCE ~A~%" href)
 240           t)
 241          (t
 242           (format t "FAIL INSTANCE ~A: failed to validate:~_ ~A~%"
 243                   href
 244                   (get-output-stream-string asdf::*VERBOSE-OUT*))
 245           nil))))
 246     (schema
 247      (handler-case
 248          (progn
 249            (cxml:parse-file (merge-pathnames href base)
 250                             (make-validator schema))
 251            (format t "PASS INSTANCE ~A~%" href)
 252            t)
 253        (rng-error (c)
 254          (format t "FAIL INSTANCE ~A: failed to validate:~_ ~A~%" href c)
 255          nil)
 256        (error (c)
 257          (format t "FAIL INSTANCE ~A: (BOGUS CONDITON) failed to validate:~_ ~A~%" href c)
 258          nil)))
 259     (t
 260      (format t "FAIL ~A: no schema~%" href)
 261      nil)))
 262
 263 (defun read-nist-grammar (href base)
 264   (let ((p (make-pathname :type "rng" :defaults href)))
 265     (handler-case
 266         (prog1
 267             (if *test-xmllint*
 268                 (namestring (merge-pathnames p base))
 269                 (parse-schema (merge-pathnames p base)))
 270           (format t "PASS ~A~%" href)
 271           t)
 272       (rng-error (c)
 273         (cond
 274           ((search ":NAME whiteSpace" (princ-to-string c))
 275            (format t "PASS ~A: whiteSpace forbidden~%" href)
 276            :ignore)
 277           ((search ":NAME enumeration" (princ-to-string c))
 278            (format t "PASS ~A: enumeration forbidden~%" href)
 279            :ignore)
 280           (t
 281            (format t "FAIL ~A: failed to parse:~_ ~A~%" href c)
 282            nil)))
 283       (error (c)
 284         (format t "FAIL ~A: (BOGUS CONDITION) failed to parse:~_ ~A~%" href c)
 285         nil))))