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
))
64 (defun run-validation-test
65 (m n
&optional
(p "/home/david/src/lisp/cxml-rng/spec-split/"))
66 (let ((d (merge-pathnames (format nil
"~3,'0D/" m
) p
))
67 (*break-on-signals
* 'error
)
70 (run-validation-tests m
71 (nth-value 1 (test1 d
))
72 (list (let ((v (merge-pathnames
73 (format nil
"~A.v.xml" n
)
78 (format nil
"~A.i.xml" n
)
81 (defun run-validation-tests (name grammar tests
)
84 (format t
"~A-~D: " name
(pathname-name x
))
86 (cxml:parse-file x
(make-validator grammar
))))
87 (if (find #\v (pathname-name x
))
94 (format t
"FAIL: ~A~%" c
)))
98 (format t
"FAIL: didn't detect invalid document~%"))
99 (dtd-compatibility-error (c)
101 (*compatibility-test-p
*
103 (format t
"PASS: ~A~%" (type-of c
)))
105 (format t
"FAIL: incorrect condition type: ~A~%" c
))))
108 (*compatibility-test-p
*
109 (format t
"FAIL: incorrect condition type: ~A~%" c
))
112 (format t
"PASS: ~A~%" (type-of c
)))))
114 (format t
"FAIL: incorrect condition type: ~A~%" c
))))))
117 (defun run-test (n &optional
(p "/home/david/src/lisp/cxml-rng/spec-split/"))
118 (test1 (merge-pathnames (format nil
"~3,'0D/" n
) p
)))
120 (defun parse-test (n &optional
(p "/home/david/src/lisp/cxml-rng/spec-split/"))
122 (d (merge-pathnames (format nil
"~3,'0D/" n
) p
))
123 (i (merge-pathnames "i.rng" d
))
124 (c (merge-pathnames "c.rng" d
))
125 (rng (if (probe-file c
) c i
)))
126 (format t
"~A: " (car (last (pathname-directory d
))))
131 (let* ((i (merge-pathnames "i.rng" d
))
132 (c (merge-pathnames "c.rng" d
)))
133 (format t
"~A: " (car (last (pathname-directory d
))))
136 (let ((grammar (parse-schema c
)))
140 (format t
" FAIL: ~A~%" c
)
145 (format t
" FAIL: didn't detect invalid schema~%")
147 (dtd-compatibility-error (c)
149 (*compatibility-test-p
*
150 (format t
" PASS: ~A~%" (type-of c
))
153 (format t
" FAIL: incorrect condition type: ~A~%" c
)
157 (*compatibility-test-p
*
158 (format t
" FAIL: incorrect condition type: ~A~%" c
)
161 (format t
" PASS: ~A~%" (type-of c
))
164 (format t
" FAIL: incorrect condition type: ~A~%" c
)
167 (defvar *test-xmllint
*)
169 (defun run-nist-tests
171 &optional
(p #p
"/home/david/NISTSchemaTests/NISTXMLSchemaTestSuite.xml"))
172 (dribble (if *test-xmllint
*
173 "/home/david/src/lisp/cxml-rng/NIST-xmllint"
174 "/home/david/src/lisp/cxml-rng/NIST")
175 :if-exists
:rename-and-delete
)
176 (klacks:with-open-source
(s (cxml:make-source p
))
180 while
(klacks:find-element s
"Link")
182 (multiple-value-bind (n i
)
183 (run-nist-tests/link
(klacks:get-attribute s
"href") p
)
187 (format t
"Passed ~D/~D tests.~%" pass total
)))
190 (defun run-nist-tests/link
(href base
)
191 (klacks:with-open-source
(r (cxml:make-source
(merge-pathnames href base
)))
196 (multiple-value-bind (key uri lname
)
201 (when (eq key
:start-element
)
203 ((equal lname
"Schema")
205 (let ((href (klacks:get-attribute r
"href")))
207 (if (or (search "-enumeration-" href
)
208 (search "-whiteSpace-" href
))
210 (read-nist-grammar href base
))))
213 ((equal lname
"Instance")
215 (when (run-nist-test/Instance schema
216 (klacks:get-attribute r
"href")
219 (values total pass
))))
221 (defun run-nist-test/Instance
(schema href base
)
224 (format t
"PASS INSTANCE ~A: (ignored)~%" href
)
227 (assert *test-xmllint
*)
228 (let ((asdf::*VERBOSE-OUT
* (make-string-output-stream)))
230 ((zerop (asdf:run-shell-command
231 "xmllint -relaxng ~A ~A"
233 (namestring (merge-pathnames href base
))))
234 (format t
"PASS INSTANCE ~A~%" href
)
237 (format t
"FAIL INSTANCE ~A: failed to validate:~_ ~A~%"
239 (get-output-stream-string asdf
::*VERBOSE-OUT
*))
244 (cxml:parse-file
(merge-pathnames href base
)
245 (make-validator schema
))
246 (format t
"PASS INSTANCE ~A~%" href
)
249 (format t
"FAIL INSTANCE ~A: failed to validate:~_ ~A~%" href c
)
252 (format t
"FAIL INSTANCE ~A: (BOGUS CONDITON) failed to validate:~_ ~A~%" href c
)
255 (format t
"FAIL ~A: no schema~%" href
)
258 (defun read-nist-grammar (href base
)
259 (let ((p (make-pathname :type
"rng" :defaults href
)))
263 (namestring (merge-pathnames p base
))
264 (parse-schema (merge-pathnames p base
)))
265 (format t
"PASS ~A~%" href
)
269 ((search ":NAME whiteSpace" (princ-to-string c
))
270 (format t
"PASS ~A: whiteSpace forbidden~%" href
)
272 ((search ":NAME enumeration" (princ-to-string c
))
273 (format t
"PASS ~A: enumeration forbidden~%" href
)
276 (format t
"FAIL ~A: failed to parse:~_ ~A~%" href c
)
279 (format t
"FAIL ~A: (BOGUS CONDITION) failed to parse:~_ ~A~%" href c
)