1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
3 ;;; An implementation of James Clark's algorithm for RELAX NG validation.
4 ;;; Copyright (c) 2007 David Lichteblau. All rights reserved.
6 ;;; Redistribution and use in source and binary forms, with or without
7 ;;; modification, are permitted provided that the following conditions
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
13 ;;; * Redistributions in binary form must reproduce the above
14 ;;; copyright notice, this list of conditions and the following
15 ;;; disclaimer in the documentation and/or other materials
16 ;;; provided with the distribution.
18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 (in-package :cxml-rng
)
33 (defvar *empty
* (make-empty))
34 (defvar *not-allowed
* (make-not-allowed))
37 (defun make-validator (schema)
38 "@arg[schema]{the parsed Relax NG @class{schema} object}
39 @return{a SAX handler}
40 @short{This function creates a validation handler for @code{schema}},
41 to be used for validation of a document against that schema.
43 The validation handler processes SAX events and can be used with any
44 function generating such events, in particular with cxml:parse-file.
47 (let* ((table (ensure-registratur schema
))
48 (start (schema-interned-start schema
))
50 (make-instance 'validator
52 :current-pattern start
)))
53 (make-instance 'text-normalizer
:chained-handler validator
)))
58 (defgeneric contains
(nc uri lname
))
60 (defmethod contains ((nc any-name
) uri lname
)
61 (let ((except (any-name-except nc
)))
63 (not (contains except uri lname
))
66 (defmethod contains ((nc ns-name
) uri lname
)
67 (and (equal (ns-name-uri nc
) uri
)
68 (let ((except (ns-name-except nc
)))
70 (not (contains except uri lname
))
73 (defmethod contains ((nc name
) uri lname
)
74 (and (equal (name-uri nc
) uri
)
75 (equal (name-lname nc
) lname
)))
77 (defmethod contains ((nc name-class-choice
) uri lname
)
78 (or (contains (name-class-choice-a nc
) uri lname
)
79 (contains (name-class-choice-b nc
) uri lname
)))
84 (defgeneric nullable
(pattern))
86 (defmethod nullable ((pattern group
))
87 (and (nullable (pattern-a pattern
))
88 (nullable (pattern-b pattern
))))
90 (defmethod nullable ((pattern interleave
))
91 (and (nullable (pattern-a pattern
))
92 (nullable (pattern-b pattern
))))
94 (defmethod nullable ((pattern choice
))
95 (or (nullable (pattern-a pattern
))
96 (nullable (pattern-b pattern
))))
98 (defmethod nullable ((pattern one-or-more
))
99 (nullable (pattern-child pattern
)))
101 (defmethod nullable ((pattern element
)) nil
)
102 (defmethod nullable ((pattern attribute
)) nil
)
103 (defmethod nullable ((pattern list-pattern
)) nil
)
104 (defmethod nullable ((pattern value
)) nil
)
105 (defmethod nullable ((pattern data
)) nil
)
106 (defmethod nullable ((pattern not-allowed
)) nil
)
107 (defmethod nullable ((pattern after
)) nil
)
109 (defmethod nullable ((pattern empty
)) t
)
110 (defmethod nullable ((pattern text
)) t
)
115 (defclass validator
(sax:sax-parser-mixin
116 cxml-types
:sax-validation-context-mixin
)
117 ((current-pattern :initarg
:current-pattern
:accessor current-pattern
)
118 (after-start-tag-p :accessor after-start-tag-p
)
119 (pending-text-node :initform nil
:accessor pending-text-node
)
120 (registratur :initarg
:registratur
:accessor registratur
)))
122 (defun advance (hsx pattern message
)
123 (when (typep pattern
'not-allowed
)
124 (rng-error hsx
"~A, was expecting a ~A"
126 (replace-scary-characters (current-pattern hsx
))))
127 (setf (current-pattern hsx
) pattern
))
129 ;; make sure slime doesn't die
130 (defun replace-scary-characters (pattern)
131 (let ((str (write-to-string pattern
138 when
(>= (char-code c
) 128)
139 do
(setf (elt str i
) #\?))
142 (defmethod sax:characters
((hsx validator
) data
)
143 (assert (null (pending-text-node hsx
))) ;parser must be normalize
144 (if (after-start-tag-p hsx
)
145 (setf (pending-text-node hsx
) data
)
146 (unless (whitespacep data
)
147 ;; we already saw an element sibling, so discard whitespace
149 (text\' hsx
(current-pattern hsx
) data
)
150 "text node not valid")))
151 (setf (after-start-tag-p hsx
) nil
))
153 (defmethod sax:start-element
((hsx validator
) uri lname qname attributes
)
154 (declare (ignore qname
))
155 (when (pending-text-node hsx
)
156 ;; text node was the previous child, and we're in element content.
157 ;; process non-whitespace now; discard whitespace completely
158 (let ((data (pending-text-node hsx
)))
159 (unless (whitespacep data
)
161 (text\' hsx
(current-pattern hsx
) data
)
163 (setf (pending-text-node hsx
) nil
))
165 (remove-if (cxml::compose
#'cxml
::xmlns-attr-p
#'sax
:attribute-qname
)
167 (let* ((p0 (current-pattern hsx
))
168 (p1 (open-start-tag\' hsx p0 uri lname
))
170 (advance hsx p1
"element not valid")
171 (attributes\' hsx p1 attributes
)))
173 (advance hsx p2
"attributes not valid")
174 (close-start-tag\' hsx p2
))))
175 (advance hsx p3
"attributes not valid")
176 (setf (after-start-tag-p hsx
) t
)))
178 (defmethod sax:end-element
((hsx validator
) uri lname qname
)
179 (declare (ignore uri lname qname
))
180 (when (after-start-tag-p hsx
)
181 ;; nothing at all? pretend we saw whitespace.
182 (sax:characters hsx
""))
183 (when (pending-text-node hsx
)
184 ;; text node was the only child?
185 ;; process it and handle whitespace specially
186 (let* ((current (current-pattern hsx
))
187 (data (pending-text-node hsx
))
188 (next (text\' hsx current data
)))
190 (if (whitespacep data
)
191 (intern-choice hsx current next
)
193 "text node not valid"))
194 (setf (pending-text-node hsx
) nil
))
196 (end-tag\' hsx
(current-pattern hsx
))
197 "end of element not valid"))
202 (defgeneric text
\' (handler pattern data
))
204 (defmethod text\' (hsx (pattern choice
) data
)
206 (text\' hsx
(pattern-a pattern
) data
)
207 (text\' hsx
(pattern-b pattern
) data
)))
209 (defmethod text\' (hsx (pattern interleave
) data
)
210 (let ((a (pattern-a pattern
))
211 (b (pattern-b pattern
)))
213 (intern-interleave hsx
(text\' hsx a data
) b
)
214 (intern-interleave hsx a
(text\' hsx b data
)))))
216 (defmethod text\' (hsx (pattern group
) data
)
217 (let* ((a (pattern-a pattern
))
218 (b (pattern-b pattern
))
219 (p (intern-group hsx
(text\' hsx a data
) b
)))
221 (intern-choice hsx p
(text\' hsx b data
))
224 (defmethod text\' (hsx (pattern after
) data
)
226 (text\' hsx
(pattern-a pattern
) data
)
227 (pattern-b pattern
)))
229 (defmethod text\' (hsx (pattern one-or-more
) data
)
230 (let ((child (pattern-child pattern
)))
232 (text\' hsx child data
)
233 (intern-zero-or-more hsx child
))))
235 (defmethod text\' (hsx (pattern text
) data
)
236 (declare (ignore data
))
240 (if ok
*empty
* *not-allowed
*))
242 (defmethod text\' (hsx (pattern value
) data
)
243 (let ((data-type (pattern-type pattern
)))
244 (eat (cxml-types:equal-using-type
246 (pattern-value pattern
)
247 (cxml-types:parse data-type data hsx
)))))
249 (defmethod text\' (hsx (pattern data
) data
)
250 (eat (and (cxml-types:validp
(pattern-type pattern
) data hsx
)
251 (let ((except (pattern-except pattern
)))
252 (not (and except
(nullable (text\' hsx except data
))))))))
254 (defmethod text\' (hsx (pattern list-pattern
) data
)
255 (eat (nullable (list\' hsx
(pattern-child pattern
) (words data
)))))
257 (defmethod text\' (hsx pattern data
)
258 (declare (ignore pattern data
))
261 (defun list\' (hsx pattern words
)
263 (setf pattern
(text\' hsx pattern word
)))
267 (cl-ppcre:split
#.
(format nil
"[~A]+" *whitespace
*)
268 (string-trim *whitespace
* str
)))
273 (defmacro ensuref
(key table value
)
274 `(ensure-hash ,key
,table
(lambda () ,value
)))
276 (defun ensure-hash (key table fn
)
277 (or (gethash key table
)
278 (setf (gethash key table
) (funcall fn
))))
280 (defgeneric intern-choice
(handler a b
))
281 (defmethod intern-choice (hsx a
(b not-allowed
)) a
)
282 (defmethod intern-choice (hsx (a not-allowed
) b
) b
)
283 (defmethod intern-choice (hsx a b
)
284 (ensuref (list 'choice a b
) (registratur hsx
) (make-choice a b
)))
286 (defgeneric intern-group
(handler a b
))
287 (defmethod intern-group (hsx (a pattern
) (b not-allowed
)) b
)
288 (defmethod intern-group (hsx (a not-allowed
) (b pattern
)) a
)
289 (defmethod intern-group (hsx a
(b empty
)) a
)
290 (defmethod intern-group (hsx (a empty
) b
) b
)
291 (defmethod intern-group (hsx a b
)
292 (ensuref (list 'group a b
) (registratur hsx
) (make-group a b
)))
294 (defgeneric intern-interleave
(handler a b
))
295 (defmethod intern-interleave (hsx (a pattern
) (b not-allowed
)) b
)
296 (defmethod intern-interleave (hsx (a not-allowed
) (b pattern
)) a
)
297 (defmethod intern-interleave (hsx a
(b empty
)) a
)
298 (defmethod intern-interleave (hsx (a empty
) b
) b
)
299 (defmethod intern-interleave (hsx a b
)
300 (ensuref (list 'interleave a b
) (registratur hsx
) (make-interleave a b
)))
302 (defgeneric intern-after
(handler a b
))
303 (defmethod intern-after (hsx (a pattern
) (b not-allowed
)) b
)
304 (defmethod intern-after (hsx (a not-allowed
) (b pattern
)) a
)
305 (defmethod intern-after (hsx a b
)
306 (ensuref (list 'after a b
) (registratur hsx
) (make-after a b
)))
308 (defgeneric intern-one-or-more
(handler c
))
309 (defmethod intern-one-or-more (hsx (c not-allowed
)) c
)
310 (defmethod intern-one-or-more (hsx c
)
311 (ensuref (list 'one-or-more c
) (registratur hsx
) (make-one-or-more c
)))
314 ;;;; ENSURE-REGISTRATUR
316 (defvar *seen-elements
*)
318 (defun ensure-registratur (grammar)
319 (or (schema-registratur grammar
)
320 (setf (schema-registratur grammar
)
321 (let ((table (make-hash-table :test
'equal
))
322 (*seen-elements
* '())
324 (setf (schema-interned-start grammar
)
325 (intern-pattern (schema-start grammar
) table
))
327 for elements
= *seen-elements
*
329 (setf *seen-elements
* nil
)
330 (dolist (pattern elements
)
331 (unless (find pattern done-elements
)
332 (push pattern done-elements
)
333 (setf (pattern-child pattern
)
334 (intern-pattern (pattern-child pattern
) table
)))))
337 ;;; FIXME: misnamed. we don't really intern the originals pattern yet.
339 (defgeneric intern-pattern
(pattern table
))
341 (defmethod intern-pattern ((pattern element
) table
)
342 (pushnew pattern
*seen-elements
*)
345 (defmethod intern-pattern ((pattern %parent
) table
)
346 (let ((c (intern-pattern (pattern-child pattern
) table
)))
347 (if (eq c
(pattern-child pattern
))
349 (let ((copy (copy-structure pattern
)))
350 (setf (pattern-child copy
) c
)
353 (defmethod intern-pattern ((pattern %combination
) table
)
354 (let ((a (intern-pattern (pattern-a pattern
) table
))
355 (b (intern-pattern (pattern-b pattern
) table
)))
356 (if (and (eq a
(pattern-a pattern
)) (eq b
(pattern-b pattern
)))
358 (let ((copy (copy-structure pattern
)))
359 (setf (pattern-a copy
) a
)
360 (setf (pattern-b copy
) b
)
363 (defmethod intern-pattern ((pattern data
) table
)
364 (let ((e (when (pattern-except pattern
)
365 (intern-pattern (pattern-except pattern
) table
))))
366 (if (eq e
(pattern-except pattern
))
368 (let ((copy (copy-structure pattern
)))
369 (setf (pattern-except copy
) e
)
372 (defmethod intern-pattern ((pattern ref
) table
)
373 (intern-pattern (defn-child (pattern-target pattern
)) table
))
375 (defmethod intern-pattern ((pattern empty
) table
)
378 (defmethod intern-pattern ((pattern not-allowed
) table
)
381 (defmethod intern-pattern ((pattern %leaf
) table
)
387 (defgeneric apply-after
(handler fn pattern
))
389 (defmethod apply-after (hsx fn
(pattern after
))
392 (funcall fn
(pattern-b pattern
))))
394 (defmethod apply-after (hsx fn
(pattern choice
))
396 (apply-after hsx fn
(pattern-a pattern
))
397 (apply-after hsx fn
(pattern-b pattern
))))
399 (defmethod apply-after (hsx fn
(pattern not-allowed
))
400 (declare (ignore hsx fn
))
406 (defgeneric open-start-tag
\' (handler pattern uri lname
))
408 (defmethod open-start-tag\' (hsx (pattern choice
) uri lname
)
410 (open-start-tag\' hsx
(pattern-a pattern
) uri lname
)
411 (open-start-tag\' hsx
(pattern-b pattern
) uri lname
)))
413 (defmethod open-start-tag\' (hsx (pattern element
) uri lname
)
414 (if (contains (pattern-name pattern
) (or uri
"") lname
)
415 (intern-after hsx
(pattern-child pattern
) *empty
*)
418 (defmethod open-start-tag\' (hsx (pattern interleave
) uri lname
)
422 (lambda (p) (intern-interleave hsx p
(pattern-b pattern
)))
423 (open-start-tag\' hsx
(pattern-a pattern
) uri lname
))
426 (lambda (p) (intern-interleave hsx
(pattern-a pattern
) p
))
427 (open-start-tag\' hsx
(pattern-b pattern
) uri lname
))))
429 (defun intern-zero-or-more (hsx c
)
430 (intern-choice hsx
(intern-one-or-more hsx c
) *empty
*))
432 (defmethod open-start-tag\' (hsx (pattern one-or-more
) uri lname
)
433 (let ((c (intern-zero-or-more hsx
(pattern-child pattern
))))
435 (lambda (p) (intern-group hsx p c
))
436 (open-start-tag\' hsx
(pattern-child pattern
) uri lname
))))
438 (defmethod open-start-tag\' (hsx (pattern group
) uri lname
)
439 (let ((x (apply-after hsx
441 (intern-group hsx p
(pattern-b pattern
)))
442 (open-start-tag\' hsx
(pattern-a pattern
) uri lname
))))
443 (if (nullable (pattern-a pattern
))
446 (open-start-tag\' hsx
(pattern-b pattern
) uri lname
))
449 (defmethod open-start-tag\' (hsx (pattern after
) uri lname
)
452 (intern-after hsx p
(pattern-b pattern
)))
453 (open-start-tag\' hsx
(pattern-a pattern
) uri lname
)))
455 (defmethod open-start-tag\' (hsx pattern uri lname
)
456 (declare (ignore hsx pattern uri lname
))
462 (defun attributes\' (handler pattern attributes
)
463 (dolist (a attributes
)
464 (setf pattern
(attribute\' handler pattern a
)))
467 (defgeneric attribute
\' (handler pattern attribute
))
469 (defmethod attribute\' (hsx (pattern after
) a
)
471 (attribute\' hsx
(pattern-a pattern
) a
)
472 (pattern-b pattern
)))
474 (defmethod attribute\' (hsx (pattern choice
) a
)
476 (attribute\' hsx
(pattern-a pattern
) a
)
477 (attribute\' hsx
(pattern-b pattern
) a
)))
479 (defmethod attribute\' (hsx (pattern group
) a
)
482 (attribute\' hsx
(pattern-a pattern
) a
)
486 (attribute\' hsx
(pattern-b pattern
) a
))))
488 (defmethod attribute\' (hsx (pattern interleave
) a
)
490 (intern-interleave hsx
491 (attribute\' hsx
(pattern-a pattern
) a
)
493 (intern-interleave hsx
495 (attribute\' hsx
(pattern-b pattern
) a
))))
497 (defmethod attribute\' (hsx (pattern one-or-more
) a
)
499 (attribute\' hsx
(pattern-child pattern
) a
)
500 (intern-zero-or-more hsx
(pattern-child pattern
))))
502 (defmethod attribute\' (hsx (pattern attribute
) a
)
503 (eat (and (contains (pattern-name pattern
)
504 (or (sax:attribute-namespace-uri a
) "")
505 (sax:attribute-local-name a
))
507 (pattern-child pattern
)
508 (sax:attribute-value a
)))))
510 (defun value-matches-p (hsx pattern value
)
511 (or (and (nullable pattern
) (whitespacep value
))
512 (nullable (text\' hsx pattern value
))))
514 (defun whitespacep (str)
515 (zerop (length (string-trim *whitespace
* str
))))
517 (defmethod attribute\' (hsx pattern a
)
518 (declare (ignore hsx pattern a
))
522 ;;;; CLOSE-START-TAG'
524 (defgeneric close-start-tag
\' (handler pattern
))
526 (defmethod close-start-tag\' (hsx (pattern after
))
528 (close-start-tag\' hsx
(pattern-a pattern
))
529 (pattern-b pattern
)))
531 (defmethod close-start-tag\' (hsx (pattern choice
))
533 (close-start-tag\' hsx
(pattern-a pattern
))
534 (close-start-tag\' hsx
(pattern-b pattern
))))
536 (defmethod close-start-tag\' (hsx (pattern group
))
538 (close-start-tag\' hsx
(pattern-a pattern
))
539 (close-start-tag\' hsx
(pattern-b pattern
))))
541 (defmethod close-start-tag\' (hsx (pattern interleave
))
542 (intern-interleave hsx
543 (close-start-tag\' hsx
(pattern-a pattern
))
544 (close-start-tag\' hsx
(pattern-b pattern
))))
546 (defmethod close-start-tag\' (hsx (pattern one-or-more
))
547 (intern-one-or-more hsx
(close-start-tag\' hsx
(pattern-child pattern
))))
549 (defmethod close-start-tag\' (hsx (pattern attribute
))
550 (declare (ignore hsx
))
553 (defmethod close-start-tag\' (hsx pattern
)
554 (declare (ignore hsx
))
560 (defgeneric end-tag
\' (handler pattern
))
562 (defmethod end-tag\' (hsx (pattern choice
))
564 (end-tag\' hsx
(pattern-a pattern
))
565 (end-tag\' hsx
(pattern-b pattern
))))
567 (defmethod end-tag\' (hsx (pattern after
))
568 (if (nullable (pattern-a pattern
))
572 (defmethod end-tag\' (hsx pattern
)
573 (declare (ignore hsx pattern
))
579 ;;; FIXME: cxml should do that
581 ;;; FIXME: since we ignore PI, CDATA, and comment events, we should probably
582 ;;; discard them properly.
584 (defclass text-normalizer
(cxml:sax-proxy
)
585 ((pending-text-node :initform
(make-string-output-stream)
586 :accessor pending-text-node
)))
588 (defmethod sax:characters
((handler text-normalizer
) data
)
589 (write-string data
(pending-text-node handler
)))
591 (defun flush-pending (handler)
592 (let ((str (get-output-stream-string (pending-text-node handler
))))
593 (unless (zerop (length str
))
594 (sax:characters
(cxml:proxy-chained-handler handler
) str
))))
596 (defmethod sax:start-element
:before
597 ((handler text-normalizer
) uri lname qname attributes
)
598 (declare (ignore uri lname qname attributes
))
599 (flush-pending handler
))
601 (defmethod sax:end-element
:before
602 ((handler text-normalizer
) uri lname qname
)
603 (declare (ignore uri lname qname
))
604 (flush-pending handler
))