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 (grammar)
38 (let* ((table (ensure-registratur grammar
))
39 (start (parsed-grammar-interned-start grammar
))
41 (make-instance 'validator
43 :current-pattern start
)))
44 (make-instance 'text-normalizer
:chained-handler validator
)))
49 (defgeneric contains
(nc uri lname
))
51 (defmethod contains ((nc any-name
) uri lname
)
52 (let ((except (any-name-except nc
)))
54 (not (contains except uri lname
))
57 (defmethod contains ((nc ns-name
) uri lname
)
58 (and (equal (ns-name-uri nc
) uri
)
59 (let ((except (ns-name-except nc
)))
61 (not (contains except uri lname
))
64 (defmethod contains ((nc name
) uri lname
)
65 (and (equal (name-uri nc
) uri
)
66 (equal (name-lname nc
) lname
)))
68 (defmethod contains ((nc name-class-choice
) uri lname
)
69 (or (contains (name-class-choice-a nc
) uri lname
)
70 (contains (name-class-choice-b nc
) uri lname
)))
75 (defgeneric nullable
(pattern))
77 (defmethod nullable ((pattern group
))
78 (and (nullable (pattern-a pattern
))
79 (nullable (pattern-b pattern
))))
81 (defmethod nullable ((pattern interleave
))
82 (and (nullable (pattern-a pattern
))
83 (nullable (pattern-b pattern
))))
85 (defmethod nullable ((pattern choice
))
86 (or (nullable (pattern-a pattern
))
87 (nullable (pattern-b pattern
))))
89 (defmethod nullable ((pattern one-or-more
))
90 (nullable (pattern-child pattern
)))
92 (defmethod nullable ((pattern element
)) nil
)
93 (defmethod nullable ((pattern attribute
)) nil
)
94 (defmethod nullable ((pattern list-pattern
)) nil
)
95 (defmethod nullable ((pattern value
)) nil
)
96 (defmethod nullable ((pattern data
)) nil
)
97 (defmethod nullable ((pattern not-allowed
)) nil
)
98 (defmethod nullable ((pattern after
)) nil
)
100 (defmethod nullable ((pattern empty
)) t
)
101 (defmethod nullable ((pattern text
)) t
)
106 (defclass validator
(sax:sax-parser-mixin
107 cxml-types
:sax-validation-context-mixin
)
108 ((current-pattern :initarg
:current-pattern
:accessor current-pattern
)
109 (after-start-tag-p :accessor after-start-tag-p
)
110 (pending-text-node :initform nil
:accessor pending-text-node
)
111 (registratur :initarg
:registratur
:accessor registratur
)))
113 (defun advance (hsx pattern message
)
114 (when (typep pattern
'not-allowed
)
115 (rng-error hsx
"~A, was expecting a ~A"
117 (replace-scary-characters (current-pattern hsx
))))
119 (write-line (replace-scary-characters (current-pattern hsx
))))
120 (setf (current-pattern hsx
) pattern
))
122 ;; make sure slime doesn't die
123 (defun replace-scary-characters (pattern)
124 (let ((str (write-to-string pattern
131 when
(>= (char-code c
) 128)
132 do
(setf (elt str i
) #\?))
135 (defmethod sax:characters
((hsx validator
) data
)
136 (assert (null (pending-text-node hsx
))) ;parser must be normalize
137 (if (after-start-tag-p hsx
)
138 (setf (pending-text-node hsx
) data
)
139 (unless (whitespacep data
)
140 ;; we already saw an element sibling, so discard whitespace
142 (text\' hsx
(current-pattern hsx
) data
)
143 "text node not valid")))
144 (setf (after-start-tag-p hsx
) nil
))
146 (defmethod sax:start-element
((hsx validator
) uri lname qname attributes
)
147 (declare (ignore qname
))
148 (when (pending-text-node hsx
)
149 ;; text node was the previous child, and we're in element content.
150 ;; process non-whitespace now; discard whitespace completely
151 (let ((data (pending-text-node hsx
)))
152 (unless (whitespacep data
)
154 (text\' hsx
(current-pattern hsx
) data
)
156 (setf (pending-text-node hsx
) nil
))
158 (remove-if (cxml::compose
#'cxml
::xmlns-attr-p
#'sax
:attribute-qname
)
160 (let* ((p0 (current-pattern hsx
))
161 (p1 (open-start-tag\' hsx p0 uri lname
))
163 (advance hsx p1
"element not valid")
164 (attributes\' hsx p1 attributes
)))
166 (advance hsx p2
"attributes not valid")
167 (close-start-tag\' hsx p2
))))
168 (advance hsx p3
"attributes not valid")
169 (setf (after-start-tag-p hsx
) t
)))
171 (defmethod sax:end-element
((hsx validator
) uri lname qname
)
172 (declare (ignore uri lname qname
))
173 (when (after-start-tag-p hsx
)
174 ;; nothing at all? pretend we saw whitespace.
175 (sax:characters hsx
""))
176 (when (pending-text-node hsx
)
177 ;; text node was the only child?
178 ;; process it and handle whitespace specially
179 (let* ((current (current-pattern hsx
))
180 (data (pending-text-node hsx
))
181 (next (text\' hsx current data
)))
183 (if (whitespacep data
)
184 (intern-choice hsx current next
)
186 "text node not valid"))
187 (setf (pending-text-node hsx
) nil
))
189 (end-tag\' hsx
(current-pattern hsx
))
190 "end of element not valid"))
195 (defgeneric text
\' (handler pattern data
))
197 (defmethod text\' (hsx (pattern choice
) data
)
199 (text\' hsx
(pattern-a pattern
) data
)
200 (text\' hsx
(pattern-b pattern
) data
)))
202 (defmethod text\' (hsx (pattern interleave
) data
)
203 (let ((a (pattern-a pattern
))
204 (b (pattern-b pattern
)))
206 (intern-interleave hsx
(text\' hsx a data
) b
)
207 (intern-interleave hsx a
(text\' hsx b data
)))))
209 (defmethod text\' (hsx (pattern group
) data
)
210 (let* ((a (pattern-a pattern
))
211 (b (pattern-b pattern
))
212 (p (intern-group hsx
(text\' hsx a data
) b
)))
214 (intern-choice hsx p
(text\' hsx b data
))
217 (defmethod text\' (hsx (pattern after
) data
)
219 (text\' hsx
(pattern-a pattern
) data
)
220 (pattern-b pattern
)))
222 (defmethod text\' (hsx (pattern one-or-more
) data
)
223 (let ((child (pattern-child pattern
)))
225 (text\' hsx child data
)
226 (intern-zero-or-more hsx child
))))
228 (defmethod text\' (hsx (pattern text
) data
)
229 (declare (ignore data
))
233 (if ok
*empty
* *not-allowed
*))
235 (defmethod text\' (hsx (pattern value
) data
)
236 (let ((data-type (pattern-type pattern
)))
237 (eat (cxml-types:equal-using-type
239 (pattern-value pattern
)
240 (cxml-types:parse data-type data hsx
)))))
242 (defmethod text\' (hsx (pattern data
) data
)
243 (eat (and (cxml-types:validp
(pattern-type pattern
) data hsx
)
244 (let ((except (pattern-except pattern
)))
245 (not (and except
(nullable (text\' hsx except data
))))))))
247 (defmethod text\' (hsx (pattern list-pattern
) data
)
248 (eat (nullable (list\' hsx
(pattern-child pattern
) (words data
)))))
250 (defmethod text\' (hsx pattern data
)
251 (declare (ignore pattern data
))
254 (defun list\' (hsx pattern words
)
256 (setf pattern
(text\' hsx pattern word
)))
260 (cl-ppcre:split
#.
(format nil
"[~A]+" *whitespace
*)
261 (string-trim *whitespace
* str
)))
266 (defmacro ensuref
(key table value
)
267 `(ensure-hash ,key
,table
(lambda () ,value
)))
269 (defun ensure-hash (key table fn
)
270 (or (gethash key table
)
271 (setf (gethash key table
) (funcall fn
))))
273 (defgeneric intern-choice
(handler a b
))
274 (defmethod intern-choice (hsx a
(b not-allowed
)) a
)
275 (defmethod intern-choice (hsx (a not-allowed
) b
) b
)
276 (defmethod intern-choice (hsx a b
)
277 (ensuref (list 'choice a b
) (registratur hsx
) (make-choice a b
)))
279 (defgeneric intern-group
(handler a b
))
280 (defmethod intern-group (hsx (a pattern
) (b not-allowed
)) b
)
281 (defmethod intern-group (hsx (a not-allowed
) (b pattern
)) a
)
282 (defmethod intern-group (hsx a
(b empty
)) a
)
283 (defmethod intern-group (hsx (a empty
) b
) b
)
284 (defmethod intern-group (hsx a b
)
285 (ensuref (list 'group a b
) (registratur hsx
) (make-group a b
)))
287 (defgeneric intern-interleave
(handler a b
))
288 (defmethod intern-interleave (hsx (a pattern
) (b not-allowed
)) b
)
289 (defmethod intern-interleave (hsx (a not-allowed
) (b pattern
)) a
)
290 (defmethod intern-interleave (hsx a
(b empty
)) a
)
291 (defmethod intern-interleave (hsx (a empty
) b
) b
)
292 (defmethod intern-interleave (hsx a b
)
293 (ensuref (list 'interleave a b
) (registratur hsx
) (make-interleave a b
)))
295 (defgeneric intern-after
(handler a b
))
296 (defmethod intern-after (hsx (a pattern
) (b not-allowed
)) b
)
297 (defmethod intern-after (hsx (a not-allowed
) (b pattern
)) a
)
298 (defmethod intern-after (hsx a b
)
299 (ensuref (list 'after a b
) (registratur hsx
) (make-after a b
)))
301 (defgeneric intern-one-or-more
(handler c
))
302 (defmethod intern-one-or-more (hsx (c not-allowed
)) c
)
303 (defmethod intern-one-or-more (hsx c
)
304 (ensuref (list 'one-or-more c
) (registratur hsx
) (make-one-or-more c
)))
307 ;;;; ENSURE-REGISTRATUR
309 (defvar *seen-elements
*)
311 (defun ensure-registratur (grammar)
312 (or (parsed-grammar-registratur grammar
)
313 (setf (parsed-grammar-registratur grammar
)
314 (let ((table (make-hash-table :test
'equal
))
315 (*seen-elements
* '())
317 (setf (parsed-grammar-interned-start grammar
)
318 (intern-pattern (parsed-grammar-pattern grammar
) table
))
320 for elements
= *seen-elements
*
322 (setf *seen-elements
* nil
)
323 (dolist (pattern elements
)
324 (unless (find pattern done-elements
)
325 (push pattern done-elements
)
326 (setf (pattern-child pattern
)
327 (intern-pattern (pattern-child pattern
) table
)))))
330 ;;; FIXME: misnamed. we don't really intern the originals pattern yet.
332 (defgeneric intern-pattern
(pattern table
))
334 (defmethod intern-pattern ((pattern element
) table
)
335 (pushnew pattern
*seen-elements
*)
338 (defmethod intern-pattern ((pattern %parent
) table
)
339 (let ((c (intern-pattern (pattern-child pattern
) table
)))
340 (if (eq c
(pattern-child pattern
))
342 (let ((copy (copy-structure pattern
)))
343 (setf (pattern-child copy
) c
)
346 (defmethod intern-pattern ((pattern %combination
) table
)
347 (let ((a (intern-pattern (pattern-a pattern
) table
))
348 (b (intern-pattern (pattern-b pattern
) table
)))
349 (if (and (eq a
(pattern-a pattern
)) (eq b
(pattern-b pattern
)))
351 (let ((copy (copy-structure pattern
)))
352 (setf (pattern-a copy
) a
)
353 (setf (pattern-b copy
) b
)
356 (defmethod intern-pattern ((pattern data
) table
)
357 (let ((e (when (pattern-except pattern
)
358 (intern-pattern (pattern-except pattern
) table
))))
359 (if (eq e
(pattern-except pattern
))
361 (let ((copy (copy-structure pattern
)))
362 (setf (pattern-except copy
) e
)
365 (defmethod intern-pattern ((pattern ref
) table
)
366 (intern-pattern (defn-child (pattern-target pattern
)) table
))
368 (defmethod intern-pattern ((pattern empty
) table
)
371 (defmethod intern-pattern ((pattern not-allowed
) table
)
374 (defmethod intern-pattern ((pattern %leaf
) table
)
380 (defgeneric apply-after
(handler fn pattern
))
382 (defmethod apply-after (hsx fn
(pattern after
))
385 (funcall fn
(pattern-b pattern
))))
387 (defmethod apply-after (hsx fn
(pattern choice
))
389 (apply-after hsx fn
(pattern-a pattern
))
390 (apply-after hsx fn
(pattern-b pattern
))))
392 (defmethod apply-after (hsx fn
(pattern not-allowed
))
393 (declare (ignore hsx fn
))
399 (defgeneric open-start-tag
\' (handler pattern uri lname
))
401 (defmethod open-start-tag\' (hsx (pattern choice
) uri lname
)
403 (open-start-tag\' hsx
(pattern-a pattern
) uri lname
)
404 (open-start-tag\' hsx
(pattern-b pattern
) uri lname
)))
406 (defmethod open-start-tag\' (hsx (pattern element
) uri lname
)
407 (if (contains (pattern-name pattern
) (or uri
"") lname
)
408 (intern-after hsx
(pattern-child pattern
) *empty
*)
411 (defmethod open-start-tag\' (hsx (pattern interleave
) uri lname
)
415 (lambda (p) (intern-interleave hsx p
(pattern-b pattern
)))
416 (open-start-tag\' hsx
(pattern-a pattern
) uri lname
))
419 (lambda (p) (intern-interleave hsx
(pattern-a pattern
) p
))
420 (open-start-tag\' hsx
(pattern-b pattern
) uri lname
))))
422 (defun intern-zero-or-more (hsx c
)
423 (intern-choice hsx
(intern-one-or-more hsx c
) *empty
*))
425 (defmethod open-start-tag\' (hsx (pattern one-or-more
) uri lname
)
426 (let ((c (intern-zero-or-more hsx
(pattern-child pattern
))))
428 (lambda (p) (intern-group hsx p c
))
429 (open-start-tag\' hsx
(pattern-child pattern
) uri lname
))))
431 (defmethod open-start-tag\' (hsx (pattern group
) uri lname
)
432 (let ((x (apply-after hsx
434 (intern-group hsx p
(pattern-b pattern
)))
435 (open-start-tag\' hsx
(pattern-a pattern
) uri lname
))))
436 (if (nullable (pattern-a pattern
))
439 (open-start-tag\' hsx
(pattern-b pattern
) uri lname
))
442 (defmethod open-start-tag\' (hsx (pattern after
) uri lname
)
445 (intern-after hsx p
(pattern-b pattern
)))
446 (open-start-tag\' hsx
(pattern-a pattern
) uri lname
)))
448 (defmethod open-start-tag\' (hsx pattern uri lname
)
449 (declare (ignore hsx pattern uri lname
))
455 (defun attributes\' (handler pattern attributes
)
456 (dolist (a attributes
)
457 (setf pattern
(attribute\' handler pattern a
)))
460 (defgeneric attribute
\' (handler pattern attribute
))
462 (defmethod attribute\' (hsx (pattern after
) a
)
464 (attribute\' hsx
(pattern-a pattern
) a
)
465 (pattern-b pattern
)))
467 (defmethod attribute\' (hsx (pattern choice
) a
)
469 (attribute\' hsx
(pattern-a pattern
) a
)
470 (attribute\' hsx
(pattern-b pattern
) a
)))
472 (defmethod attribute\' (hsx (pattern group
) a
)
475 (attribute\' hsx
(pattern-a pattern
) a
)
479 (attribute\' hsx
(pattern-b pattern
) a
))))
481 (defmethod attribute\' (hsx (pattern interleave
) a
)
483 (intern-interleave hsx
484 (attribute\' hsx
(pattern-a pattern
) a
)
486 (intern-interleave hsx
488 (attribute\' hsx
(pattern-b pattern
) a
))))
490 (defmethod attribute\' (hsx (pattern one-or-more
) a
)
492 (attribute\' hsx
(pattern-child pattern
) a
)
493 (intern-zero-or-more hsx
(pattern-child pattern
))))
495 (defmethod attribute\' (hsx (pattern attribute
) a
)
496 (eat (and (contains (pattern-name pattern
)
497 (or (sax:attribute-namespace-uri a
) "")
498 (sax:attribute-local-name a
))
500 (pattern-child pattern
)
501 (sax:attribute-value a
)))))
503 (defun value-matches-p (hsx pattern value
)
504 (or (and (nullable pattern
) (whitespacep value
))
505 (nullable (text\' hsx pattern value
))))
507 (defun whitespacep (str)
508 (zerop (length (string-trim *whitespace
* str
))))
510 (defmethod attribute\' (hsx pattern a
)
511 (declare (ignore hsx pattern a
))
515 ;;;; CLOSE-START-TAG'
517 (defgeneric close-start-tag
\' (handler pattern
))
519 (defmethod close-start-tag\' (hsx (pattern after
))
521 (close-start-tag\' hsx
(pattern-a pattern
))
522 (pattern-b pattern
)))
524 (defmethod close-start-tag\' (hsx (pattern choice
))
526 (close-start-tag\' hsx
(pattern-a pattern
))
527 (close-start-tag\' hsx
(pattern-b pattern
))))
529 (defmethod close-start-tag\' (hsx (pattern group
))
531 (close-start-tag\' hsx
(pattern-a pattern
))
532 (close-start-tag\' hsx
(pattern-b pattern
))))
534 (defmethod close-start-tag\' (hsx (pattern interleave
))
535 (intern-interleave hsx
536 (close-start-tag\' hsx
(pattern-a pattern
))
537 (close-start-tag\' hsx
(pattern-b pattern
))))
539 (defmethod close-start-tag\' (hsx (pattern one-or-more
))
540 (intern-one-or-more hsx
(close-start-tag\' hsx
(pattern-child pattern
))))
542 (defmethod close-start-tag\' (hsx (pattern attribute
))
543 (declare (ignore hsx
))
546 (defmethod close-start-tag\' (hsx pattern
)
547 (declare (ignore hsx
))
553 (defgeneric end-tag
\' (handler pattern
))
555 (defmethod end-tag\' (hsx (pattern choice
))
557 (end-tag\' hsx
(pattern-a pattern
))
558 (end-tag\' hsx
(pattern-b pattern
))))
560 (defmethod end-tag\' (hsx (pattern after
))
561 (if (nullable (pattern-a pattern
))
565 (defmethod end-tag\' (hsx pattern
)
566 (declare (ignore hsx pattern
))
572 ;;; FIXME: cxml should do that
574 ;;; FIXME: since we ignore PI, CDATA, and comment events, we should probably
575 ;;; discard them properly.
577 (defclass text-normalizer
(cxml:sax-proxy
)
578 ((pending-text-node :initform
(make-string-output-stream)
579 :accessor pending-text-node
)))
581 (defmethod sax:characters
((handler text-normalizer
) data
)
582 (write-string data
(pending-text-node handler
)))
584 (defun flush-pending (handler)
585 (let ((str (get-output-stream-string (pending-text-node handler
))))
586 (unless (zerop (length str
))
587 (sax:characters
(cxml:proxy-chained-handler handler
) str
))))
589 (defmethod sax:start-element
:before
590 ((handler text-normalizer
) uri lname qname attributes
)
591 (declare (ignore uri lname qname attributes
))
592 (flush-pending handler
))
594 (defmethod sax:end-element
:before
595 ((handler text-normalizer
) uri lname qname
)
596 (declare (ignore uri lname qname
))
597 (flush-pending handler
))