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   (dribble "/home/david/src/lisp/cxml-rng/TEST" :if-exists :rename-and-delete)
  34   (let ((pass 0)
  35         (total 0)
  36         (*package* (find-package :cxml-rng))
  37         (*print-level* 3))
  38     (dolist (d (directory p))
  39       (let ((name (car (last (pathname-directory d)))))
  40         (when (parse-integer name :junk-allowed t)
  41           (let ((xml (directory (merge-pathnames "*.xml" d))))
  42             (incf total (1+ (length xml)))
  43             (multiple-value-bind (ok grammar) (test1 d)
  44               (cond
  45                 (ok
  46                  (incf pass (1+ (run-validation-tests name grammar xml))))
  47                 (t
  48                  (dolist (x xml)
  49                    (format t "~A-~D: FAIL: cannot run test~%"
  50                            name
  51                            (pathname-name x))))))))))
  52     (format t "Passed ~D/~D tests.~%" pass total))
  53   (dribble))
  54
  55 (defun run-validation-test
  56     (m n &optional (p "/home/david/src/lisp/cxml-rng/spec-split/"))
  57   (let ((d (merge-pathnames (format nil "~3,'0D/" m) p))
  58         (*break-on-signals* 'error)
  59         (*debug* t)
  60         (*print-level* 3))
  61     (run-validation-tests m
  62                           (nth-value 1 (test1 d))
  63                           (list (let ((v (merge-pathnames
  64                                           (format nil "~A.v.xml" n)
  65                                           d)))
  66                                   (if (probe-file v)
  67                                       v
  68                                       (merge-pathnames
  69                                        (format nil "~A.i.xml" n)
  70                                        d)))))))
  71
  72 (defun run-validation-tests (name grammar tests)
  73   (let ((pass 0))
  74     (dolist (x tests)
  75       (format t "~A-~D: " name (pathname-name x))
  76       (flet ((doit ()
  77                (cxml:parse-file x (make-validator grammar))))
  78         (if (find #\v (pathname-name x))
  79             (handler-case
  80                 (progn
  81                   (doit)
  82                   (incf pass)
  83                   (format t "PASS~%"))
  84               (error (c)
  85                 (format t "FAIL: ~A~%" c)))
  86             (handler-case
  87                 (progn
  88                   (doit)
  89                   (format t "FAIL: didn't detect invalid document~%"))
  90               (rng-error (c)
  91                 (incf pass)
  92                 (format t "PASS: ~A~%" (type-of c)))
  93               (error (c)
  94                 (format t "FAIL: incorrect condition type: ~A~%" c))))))
  95     pass))
  96
  97 (defun run-test (n &optional (p "/home/david/src/lisp/cxml-rng/spec-split/"))
  98   (test1 (merge-pathnames (format nil "~3,'0D/" n) p)))
  99
 100 (defun parse-test (n &optional (p "/home/david/src/lisp/cxml-rng/spec-split/"))
 101   (let* ((*debug* t)
 102          (d (merge-pathnames (format nil "~3,'0D/" n) p))
 103          (i (merge-pathnames "i.rng" d))
 104          (c (merge-pathnames "c.rng" d))
 105          (rng (if (probe-file c) c i)))
 106     (format t "~A: " (car (last (pathname-directory d))))
 107     (print rng)
 108     (parse-schema rng)))
 109
 110 (defun test1 (d)
 111   (let* ((i (merge-pathnames "i.rng" d))
 112          (c (merge-pathnames "c.rng" d)))
 113     (format t "~A: " (car (last (pathname-directory d))))
 114     (if (probe-file c)
 115         (handler-case
 116             (let ((grammar (parse-schema c)))
 117               (format t " PASS~%")
 118               (values t grammar))
 119           (error (c)
 120             (format t " FAIL: ~A~%" c)
 121             nil))
 122         (handler-case
 123             (progn
 124               (parse-schema i)
 125               (format t " FAIL: didn't detect invalid schema~%")
 126               nil)
 127           (rng-error (c)
 128             (format t " PASS: ~S~%" (type-of c))
 129             t)
 130           (error (c)
 131             (format t " FAIL: incorrect condition type: ~A~%" c)
 132             nil)))))
 133
 134 (defvar *test-xmllint*)
 135
 136 (defun run-nist-tests
 137     (*test-xmllint*
 138      &optional (p #p"/home/david/NISTSchemaTests/NISTXMLSchemaTestSuite.xml"))
 139   (dribble (if *test-xmllint*
 140                "/home/david/src/lisp/cxml-rng/NIST-xmllint"
 141                "/home/david/src/lisp/cxml-rng/NIST")
 142            :if-exists :rename-and-delete)
 143   (klacks:with-open-source (s (cxml:make-source p))
 144     (let ((total 0)
 145           (pass 0))
 146       (loop
 147          while (klacks:find-element s "Link")
 148          do
 149            (multiple-value-bind (n i)
 150                (run-nist-tests/link (klacks:get-attribute s "href") p)
 151              (incf total n)
 152              (incf pass i))
 153            (klacks:consume s))
 154       (format t "Passed ~D/~D tests.~%" pass total)))
 155   (dribble))
 156
 157 (defun run-nist-tests/link (href base)
 158   (klacks:with-open-source (r (cxml:make-source (merge-pathnames href base)))
 159     (let ((total 0)
 160           (pass 0))
 161       (let (schema)
 162         (loop
 163            (multiple-value-bind (key uri lname)
 164                (klacks:peek-next r)
 165              uri
 166              (unless key
 167                (return))
 168              (when (eq key :start-element)
 169                (cond
 170                  ((equal lname "Schema")
 171                   (incf total)
 172                   (let ((href (klacks:get-attribute r "href")))
 173                     (setf schema
 174                           (if (or (search "-enumeration-" href)
 175                                   (search "-whiteSpace-" href))
 176                               :ignore
 177                               (read-nist-grammar href base))))
 178                   (when schema
 179                     (incf total)))
 180                  ((equal lname "Instance")
 181                   (incf total)
 182                   (when (run-nist-test/Instance schema
 183                                                 (klacks:get-attribute r "href")
 184                                                 base)
 185                     (incf pass))))))))
 186       (values total pass))))
 187
 188 (defun run-nist-test/Instance (schema href base)
 189   (cond
 190     ((eq schema :ignore)
 191      (format t "PASS INSTANCE ~A: (ignored)~%" href)
 192      t)
 193     ((stringp schema)
 194      (assert *test-xmllint*)
 195      (let ((asdf::*VERBOSE-OUT* (make-string-output-stream)))
 196        (cond
 197          ((zerop (asdf:run-shell-command
 198                   "xmllint -relaxng ~A ~A"
 199                   schema
 200                   (namestring (merge-pathnames href base))))
 201           (format t "PASS INSTANCE ~A~%" href)
 202           t)
 203          (t
 204           (format t "FAIL INSTANCE ~A: failed to validate:~_ ~A~%"
 205                   href
 206                   (get-output-stream-string asdf::*VERBOSE-OUT*))
 207           nil))))
 208     (schema
 209      (handler-case
 210          (progn
 211            (cxml:parse-file (merge-pathnames href base)
 212                             (make-validator schema))
 213            (format t "PASS INSTANCE ~A~%" href)
 214            t)
 215        (rng-error (c)
 216          (format t "FAIL INSTANCE ~A: failed to validate:~_ ~A~%" href c)
 217          nil)
 218        (error (c)
 219          (format t "FAIL INSTANCE ~A: (BOGUS CONDITON) failed to validate:~_ ~A~%" href c)
 220          nil)))
 221     (t
 222      (format t "FAIL ~A: no schema~%" href)
 223      nil)))
 224
 225 (defun read-nist-grammar (href base)
 226   (let ((p (make-pathname :type "rng" :defaults href)))
 227     (handler-case
 228         (prog1
 229             (if *test-xmllint*
 230                 (namestring (merge-pathnames p base))
 231                 (parse-schema (merge-pathnames p base)))
 232           (format t "PASS ~A~%" href)
 233           t)
 234       (rng-error (c)
 235         (cond
 236           ((search ":NAME whiteSpace" (princ-to-string c))
 237            (format t "PASS ~A: whiteSpace forbidden~%" href)
 238            :ignore)
 239           ((search ":NAME enumeration" (princ-to-string c))
 240            (format t "PASS ~A: enumeration forbidden~%" href)
 241            :ignore)
 242           (t
 243            (format t "FAIL ~A: failed to parse:~_ ~A~%" href c)
 244            nil)))
 245       (error (c)
 246         (format t "FAIL ~A: (BOGUS CONDITION) failed to parse:~_ ~A~%" href c)
 247         nil))))