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