1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
3 ;;; Copyright (c) 2007 David Lichteblau. All rights reserved.
5 ;;; Redistribution and use in source and binary forms, with or without
6 ;;; modification, are permitted provided that the following conditions
9 ;;; * Redistributions of source code must retain the above copyright
10 ;;; notice, this list of conditions and the following disclaimer.
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.
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.
30 (in-package :cxml-rng
)
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
)
37 (*package
* (find-package :cxml-rng
))
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
)
47 (incf pass
(1+ (run-validation-tests name grammar xml
))))
50 (format t
"~A-~D: FAIL: cannot run test~%"
52 (pathname-name x
))))))))))
53 (format t
"Passed ~D/~D tests.~%" pass total
))
56 (defvar *compatibility-test-p
* nil
)
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
))
65 (n &optional
(p "/home/david/src/lisp/cxml-rng/dtd-split/*"))
66 (let ((*break-on-signals
* 'error
))
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
)
75 (run-validation-tests m
76 (nth-value 1 (test1 d
))
77 (list (let ((v (merge-pathnames
78 (format nil
"~A.v.xml" n
)
83 (format nil
"~A.i.xml" n
)
86 (defun run-validation-tests (name grammar tests
)
89 (format t
"~A-~D: " name
(pathname-name x
))
91 (cxml:parse-file x
(make-dtd-compatibility-handler
93 (make-validator grammar
)))))
94 (if (find #\v (pathname-name x
))
101 (format t
"FAIL: ~A~%" c
)))
105 (format t
"FAIL: didn't detect invalid document~%"))
106 (dtd-compatibility-error (c)
108 (*compatibility-test-p
*
110 (format t
"PASS: ~A~%" (type-of c
)))
112 (format t
"FAIL: incorrect condition type (a): ~A~%" c
))))
115 (*compatibility-test-p
*
116 (format t
"FAIL: incorrect condition type (b): ~A~%" c
))
119 (format t
"PASS: ~A~%" (type-of c
)))))
121 (format t
"FAIL: incorrect condition type (c): ~A~%" c
))))))
124 (defun run-test (n &optional
(p "/home/david/src/lisp/cxml-rng/spec-split/"))
125 (test1 (merge-pathnames (format nil
"~3,'0D/" n
) p
)))
127 (defun parse-test (n &optional
(p "/home/david/src/lisp/cxml-rng/spec-split/"))
129 (d (merge-pathnames (format nil
"~3,'0D/" n
) p
))
130 (i (merge-pathnames "i.rng" d
))
131 (c (merge-pathnames "c.rng" d
))
132 (rng (if (probe-file c
) c i
)))
133 (format t
"~A: " (car (last (pathname-directory d
))))
138 (let* ((i (merge-pathnames "i.rng" d
))
139 (c (merge-pathnames "c.rng" d
)))
140 (format t
"~A: " (car (last (pathname-directory d
))))
143 (let ((grammar (parse-schema c
)))
147 (format t
" FAIL: ~A~%" c
)
152 (format t
" FAIL: didn't detect invalid schema~%")
154 (dtd-compatibility-error (c)
156 (*compatibility-test-p
*
157 (format t
" PASS: ~A~%" (type-of c
))
160 (format t
" FAIL: incorrect condition type (A): ~A~%" c
)
164 (*compatibility-test-p
*
165 (format t
" FAIL: incorrect condition type (B): ~A~%" c
)
168 (format t
" PASS: ~A~%" (type-of c
))
171 (format t
" FAIL: incorrect condition type (C): ~A~%" c
)
174 (defvar *test-xmllint
*)
176 (defun run-nist-tests
178 &optional
(p #p
"/home/david/NISTSchemaTests/NISTXMLSchemaTestSuite.xml"))
179 (dribble (if *test-xmllint
*
180 "/home/david/src/lisp/cxml-rng/NIST-xmllint"
181 "/home/david/src/lisp/cxml-rng/NIST")
182 :if-exists
:rename-and-delete
)
183 (klacks:with-open-source
(s (cxml:make-source p
))
187 while
(klacks:find-element s
"Link")
189 (multiple-value-bind (n i
)
190 (run-nist-tests/link
(klacks:get-attribute s
"href") p
)
194 (format t
"Passed ~D/~D tests.~%" pass total
)))
197 (defun run-nist-tests/link
(href base
)
198 (klacks:with-open-source
(r (cxml:make-source
(merge-pathnames href base
)))
203 (multiple-value-bind (key uri lname
)
208 (when (eq key
:start-element
)
210 ((equal lname
"Schema")
212 (let ((href (klacks:get-attribute r
"href")))
214 (if (or (search "-enumeration-" href
)
215 (search "-whiteSpace-" href
))
217 (read-nist-grammar href base
))))
220 ((equal lname
"Instance")
222 (when (run-nist-test/Instance schema
223 (klacks:get-attribute r
"href")
226 (values total pass
))))
228 (defun run-nist-test/Instance
(schema href base
)
231 (format t
"PASS INSTANCE ~A: (ignored)~%" href
)
234 (assert *test-xmllint
*)
235 (let ((asdf::*VERBOSE-OUT
* (make-string-output-stream)))
237 ((zerop (asdf:run-shell-command
238 "xmllint -relaxng ~A ~A"
240 (namestring (merge-pathnames href base
))))
241 (format t
"PASS INSTANCE ~A~%" href
)
244 (format t
"FAIL INSTANCE ~A: failed to validate:~_ ~A~%"
246 (get-output-stream-string asdf
::*VERBOSE-OUT
*))
251 (cxml:parse-file
(merge-pathnames href base
)
252 (make-validator schema
))
253 (format t
"PASS INSTANCE ~A~%" href
)
256 (format t
"FAIL INSTANCE ~A: failed to validate:~_ ~A~%" href c
)
259 (format t
"FAIL INSTANCE ~A: (BOGUS CONDITON) failed to validate:~_ ~A~%" href c
)
262 (format t
"FAIL ~A: no schema~%" href
)
265 (defun read-nist-grammar (href base
)
266 (let ((p (make-pathname :type
"rng" :defaults href
)))
270 (namestring (merge-pathnames p base
))
271 (parse-schema (merge-pathnames p base
)))
272 (format t
"PASS ~A~%" href
)
276 ((search ":NAME whiteSpace" (princ-to-string c
))
277 (format t
"PASS ~A: whiteSpace forbidden~%" href
)
279 ((search ":NAME enumeration" (princ-to-string c
))
280 (format t
"PASS ~A: enumeration forbidden~%" href
)
283 (format t
"FAIL ~A: failed to parse:~_ ~A~%" href c
)
286 (format t
"FAIL ~A: (BOGUS CONDITION) failed to parse:~_ ~A~%" href c
)