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))
36 (defmacro ensuref
(key table value
)
37 `(ensure-hash ,key
,table
(lambda () ,value
)))
39 (defun ensure-hash (key table fn
)
40 (or (gethash key table
)
41 (setf (gethash key table
) (funcall fn
))))
44 (defun make-validator (schema)
45 "@arg[schema]{the parsed Relax NG @class{schema} object}
46 @return{a SAX handler}
47 @short{This function creates a validation handler for @code{schema}},
48 to be used for validation of a document against that schema.
50 The validation handler processes SAX events and can be used with any
51 function generating such events, in particular with cxml:parse-file.
54 (let* ((table (ensure-registratur schema
))
55 (start (schema-interned-start schema
))
57 (make-instance 'validator
59 :current-pattern start
)))
60 (make-instance 'text-normalizer
:chained-handler validator
)))
65 (defgeneric contains
(nc uri lname
))
67 (defmethod contains ((nc any-name
) uri lname
)
68 (let ((except (any-name-except nc
)))
70 (not (contains except uri lname
))
73 (defmethod contains ((nc ns-name
) uri lname
)
74 (and (equal (ns-name-uri nc
) uri
)
75 (let ((except (ns-name-except nc
)))
77 (not (contains except uri lname
))
80 (defmethod contains ((nc name
) uri lname
)
81 (and (equal (name-uri nc
) uri
)
82 (equal (name-lname nc
) lname
)))
84 (defmethod contains ((nc name-class-choice
) uri lname
)
85 (or (contains (name-class-choice-a nc
) uri lname
)
86 (contains (name-class-choice-b nc
) uri lname
)))
91 (defun finalize-pattern (p)
92 (setf (pattern-nullable p
) (compute-nullable p
))
95 (defun nullable (pattern)
96 (let ((np (pattern-nullable pattern
)))
97 (check-type np boolean
) ;initialized by intern-pattern
100 (defgeneric compute-nullable
(pattern))
102 (defmethod compute-nullable ((pattern group
))
103 (and (nullable (pattern-a pattern
))
104 (nullable (pattern-b pattern
))))
106 (defmethod compute-nullable ((pattern interleave
))
107 (and (nullable (pattern-a pattern
))
108 (nullable (pattern-b pattern
))))
110 (defmethod compute-nullable ((pattern choice
))
111 (or (nullable (pattern-a pattern
))
112 (nullable (pattern-b pattern
))))
114 (defmethod compute-nullable ((pattern one-or-more
))
115 (nullable (pattern-child pattern
)))
117 (defmethod compute-nullable ((pattern element
)) nil
)
118 (defmethod compute-nullable ((pattern attribute
)) nil
)
119 (defmethod compute-nullable ((pattern list-pattern
)) nil
)
120 (defmethod compute-nullable ((pattern value
)) nil
)
121 (defmethod compute-nullable ((pattern data
)) nil
)
122 (defmethod compute-nullable ((pattern not-allowed
)) nil
)
123 (defmethod compute-nullable ((pattern after
)) nil
)
125 (defmethod compute-nullable ((pattern empty
)) t
)
126 (defmethod compute-nullable ((pattern text
)) t
)
131 (defclass validator
(sax:sax-parser-mixin
132 cxml-types
:sax-validation-context-mixin
)
133 ((current-pattern :initarg
:current-pattern
:accessor current-pattern
)
134 (after-start-tag-p :accessor after-start-tag-p
)
135 (pending-text-node :initform nil
:accessor pending-text-node
)
136 (registratur :initarg
:registratur
:accessor registratur
)
137 (open-start-tag\'-cache
:initform
(make-hash-table :test
'equal
)
138 :reader open-start-tag
\'-cache
)
139 (close-start-tag\'-cache
:initform
(make-hash-table)
140 :reader close-start-tag
\'-cache
)
141 (end-tag\'-cache
:initform
(make-hash-table) :reader end-tag
\'-cache
)
142 (non-element\'-cache
:initform
(make-hash-table)
143 :reader non-element
\'-cache
)
144 (mixed-text\'-cache
:initform
(make-hash-table)
145 :reader mixed-text
\'-cache
)))
147 (defun advance (hsx pattern message
&rest args
)
148 (when (typep pattern
'not-allowed
)
149 (rng-error hsx
"~?, was expecting ~A"
152 (replace-scary-characters
153 (with-output-to-string (s)
154 (expectation (current-pattern hsx
) s
)))))
155 (setf (current-pattern hsx
) pattern
))
157 ;; make sure slime doesn't die
158 (defun replace-scary-characters (pattern)
159 (let ((str (write-to-string pattern
166 when
(>= (char-code c
) 128)
167 do
(setf (elt str i
) #\?))
170 (defmethod sax:characters
((hsx validator
) data
)
171 (assert (null (pending-text-node hsx
))) ;parser must be normalize
172 (if (after-start-tag-p hsx
)
173 (setf (pending-text-node hsx
) data
)
174 (unless (whitespacep data
)
175 ;; we already saw an element sibling, so discard whitespace
177 (mixed-text\' hsx
(current-pattern hsx
))
178 "text node not valid")))
179 (setf (after-start-tag-p hsx
) nil
))
181 (defmethod sax:start-element
((hsx validator
) uri lname qname attributes
)
182 (declare (ignore qname
))
183 (when (pending-text-node hsx
)
184 ;; text node was the previous child, and we're in element content.
185 ;; process non-whitespace now; discard whitespace completely
186 (let ((data (pending-text-node hsx
)))
187 (unless (whitespacep data
)
189 (mixed-text\' hsx
(current-pattern hsx
))
191 (setf (pending-text-node hsx
) nil
))
193 (remove-if (cxml::compose
#'cxml
::xmlns-attr-p
#'sax
:attribute-qname
)
195 (let* ((p0 (current-pattern hsx
))
196 (p1 (open-start-tag\' hsx p0 uri lname
))
198 (advance hsx p1
"element ~A (~A) not valid" lname uri
)
199 (attributes\' hsx p1 attributes
)))
201 (advance hsx p2
"attributes not valid")
202 (close-start-tag\' hsx p2
))))
203 (advance hsx p3
"attributes not valid")
204 (setf (after-start-tag-p hsx
) t
)))
206 (defmethod sax:end-element
((hsx validator
) uri lname qname
)
207 (declare (ignore uri lname qname
))
208 (when (after-start-tag-p hsx
)
209 ;; nothing at all? pretend we saw whitespace.
210 (sax:characters hsx
""))
211 (when (pending-text-node hsx
)
212 ;; text node was the only child?
213 ;; process it and handle whitespace specially
214 (let* ((current (current-pattern hsx
))
215 (data (pending-text-node hsx
))
216 (next (text-only\' hsx current data
)))
218 (if (whitespacep data
)
219 (intern-choice hsx current next
)
221 "text node not valid"))
222 (setf (pending-text-node hsx
) nil
))
224 (end-tag\' hsx
(current-pattern hsx
))
225 "end of element not valid"))
228 (if ok
*empty
* *not-allowed
*))
231 ;;;; TEXT-ONLY' / NON-ELEMENT'
233 (defun text-only\' (handler pattern data
)
235 (non-element\' handler pattern
)
238 (defgeneric non-element
\' (handler pattern
))
240 (defmethod non-element\' :around
(hsx (pattern pattern
))
241 (ensuref pattern
(non-element\'-cache hsx
) (call-next-method)))
243 (defmethod non-element\' (hsx (pattern choice
))
245 (non-element\' hsx
(pattern-a pattern
))
246 (non-element\' hsx
(pattern-b pattern
))))
248 (defmethod non-element\' (hsx (pattern interleave
))
249 (let ((a (pattern-a pattern
))
250 (b (pattern-b pattern
)))
252 (intern-interleave hsx
(non-element\' hsx a
) b
)
253 (intern-interleave hsx a
(non-element\' hsx b
)))))
255 (defmethod non-element\' (hsx (pattern group
))
256 (let* ((a (pattern-a pattern
))
257 (b (pattern-b pattern
))
258 (p (intern-group hsx
(non-element\' hsx a
) b
)))
260 (intern-choice hsx p
(non-element\' hsx b
))
263 (defmethod non-element\' (hsx (pattern after
))
265 (non-element\' hsx
(pattern-a pattern
))
266 (pattern-b pattern
)))
268 (defmethod non-element\' (hsx (pattern one-or-more
))
269 (let ((child (pattern-child pattern
)))
271 (non-element\' hsx child
)
272 (intern-zero-or-more hsx child
))))
274 (defmethod non-element\' (hsx (pattern element
))
277 (defmethod non-element\' (hsx pattern
)
283 (defgeneric data
\' (handler pattern data
))
285 (defmethod data\' (hsx (pattern choice
) data
)
287 (data\' hsx
(pattern-a pattern
) data
)
288 (data\' hsx
(pattern-b pattern
) data
)))
290 (defmethod data\' (hsx (pattern interleave
) data
)
291 (let ((a (pattern-a pattern
))
292 (b (pattern-b pattern
)))
294 (intern-interleave hsx
(data\' hsx a data
) b
)
295 (intern-interleave hsx a
(data\' hsx b data
)))))
297 (defmethod data\' (hsx (pattern group
) data
)
298 (let* ((a (pattern-a pattern
))
299 (b (pattern-b pattern
))
300 (p (intern-group hsx
(data\' hsx a data
) b
)))
302 (intern-choice hsx p
(data\' hsx b data
))
305 (defmethod data\' (hsx (pattern after
) data
)
307 (data\' hsx
(pattern-a pattern
) data
)
308 (pattern-b pattern
)))
310 (defmethod data\' (hsx (pattern one-or-more
) data
)
311 (let ((child (pattern-child pattern
)))
313 (data\' hsx child data
)
314 (intern-zero-or-more hsx child
))))
316 (defmethod data\' (hsx (pattern text
) data
)
317 (declare (ignore data
))
320 (defmethod data\' (hsx (pattern value
) data
)
321 (let ((data-type (pattern-type pattern
)))
322 (eat (cxml-types:equal-using-type
324 (pattern-value pattern
)
325 (cxml-types:parse data-type data hsx
)))))
327 (defmethod data\' (hsx (pattern data
) data
)
328 (eat (and (cxml-types:validp
(pattern-type pattern
) data hsx
)
329 (let ((except (pattern-except pattern
)))
330 (not (and except
(nullable (data\' hsx except data
))))))))
332 (defmethod data\' (hsx (pattern list-pattern
) data
)
333 (eat (nullable (list\' hsx
(pattern-child pattern
) (words data
)))))
335 (defmethod data\' (hsx pattern data
)
336 (declare (ignore pattern data
))
339 (defun list\' (hsx pattern words
)
341 (setf pattern
(data\' hsx pattern word
)))
345 (cl-ppcre:split
#.
(format nil
"[~A]+" *whitespace
*)
346 (string-trim *whitespace
* str
)))
351 (defgeneric mixed-text
\' (handler pattern
))
353 (defmethod mixed-text\' :around
(hsx (pattern pattern
))
354 (ensuref pattern
(mixed-text\'-cache hsx
) (call-next-method)))
356 (defmethod mixed-text\' (hsx (pattern choice
))
358 (mixed-text\' hsx
(pattern-a pattern
))
359 (mixed-text\' hsx
(pattern-b pattern
))))
361 (defmethod mixed-text\' (hsx (pattern interleave
))
362 (let ((a (pattern-a pattern
))
363 (b (pattern-b pattern
)))
365 (intern-interleave hsx
(mixed-text\' hsx a
) b
)
366 (intern-interleave hsx a
(mixed-text\' hsx b
)))))
368 (defmethod mixed-text\' (hsx (pattern group
))
369 (let* ((a (pattern-a pattern
))
370 (b (pattern-b pattern
))
371 (p (intern-group hsx
(mixed-text\' hsx a
) b
)))
373 (intern-choice hsx p
(mixed-text\' hsx b
))
376 (defmethod mixed-text\' (hsx (pattern after
))
378 (mixed-text\' hsx
(pattern-a pattern
))
379 (pattern-b pattern
)))
381 (defmethod mixed-text\' (hsx (pattern one-or-more
))
382 (let ((child (pattern-child pattern
)))
384 (mixed-text\' hsx child
)
385 (intern-zero-or-more hsx child
))))
387 (defmethod mixed-text\' (hsx (pattern text
))
390 (defmethod mixed-text\' (hsx pattern
)
391 (declare (ignore pattern
))
397 (defgeneric intern-choice
(handler a b
))
398 (defmethod intern-choice (hsx a
(b not-allowed
)) a
)
399 (defmethod intern-choice (hsx (a not-allowed
) b
) b
)
400 (defmethod intern-choice (hsx a b
)
401 (ensuref (list 'choice a b
)
403 (let ((table (make-hash-table)))
407 (record (pattern-a p
))
408 (record (pattern-b p
)))
410 (setf (gethash p table
) t
)))))
412 (labels ((eliminate (p)
416 (eliminate (pattern-a p
))
417 (eliminate (pattern-b p
))))
422 (let ((x (eliminate b
)))
423 (if (typep x
'not-allowed
)
425 (finalize-pattern (make-choice a x
))))))))
427 (defgeneric intern-group
(handler a b
))
428 (defmethod intern-group (hsx (a pattern
) (b not-allowed
)) b
)
429 (defmethod intern-group (hsx (a not-allowed
) (b pattern
)) a
)
430 (defmethod intern-group (hsx a
(b empty
)) a
)
431 (defmethod intern-group (hsx (a empty
) b
) b
)
432 (defmethod intern-group (hsx a b
)
433 (ensuref (list 'group a b
)
435 (finalize-pattern (make-group a b
))))
437 (defgeneric intern-interleave
(handler a b
))
438 (defmethod intern-interleave (hsx (a pattern
) (b not-allowed
)) b
)
439 (defmethod intern-interleave (hsx (a not-allowed
) (b pattern
)) a
)
440 (defmethod intern-interleave (hsx a
(b empty
)) a
)
441 (defmethod intern-interleave (hsx (a empty
) b
) b
)
442 (defmethod intern-interleave (hsx a b
)
443 (ensuref (list 'interleave a b
)
445 (finalize-pattern (make-interleave a b
))))
447 (defgeneric intern-after
(handler a b
))
448 (defmethod intern-after (hsx (a pattern
) (b not-allowed
)) b
)
449 (defmethod intern-after (hsx (a not-allowed
) (b pattern
)) a
)
450 (defmethod intern-after (hsx a b
)
451 (ensuref (list 'after a b
)
453 (finalize-pattern (make-after a b
))))
455 (defgeneric intern-one-or-more
(handler c
))
456 (defmethod intern-one-or-more (hsx (c not-allowed
)) c
)
457 (defmethod intern-one-or-more (hsx c
)
458 (ensuref (list 'one-or-more c
)
460 (finalize-pattern (make-one-or-more c
))))
463 ;;;; ENSURE-REGISTRATUR
465 (defvar *seen-elements
*)
467 (defun ensure-registratur (grammar)
468 (or (schema-registratur grammar
)
469 (setf (schema-registratur grammar
)
470 (let ((table (make-hash-table :test
'equal
))
471 (*seen-elements
* '())
473 (setf (schema-interned-start grammar
)
474 (intern-pattern (schema-start grammar
) table
))
476 for elements
= *seen-elements
*
478 (setf *seen-elements
* nil
)
479 (dolist (pattern elements
)
480 (unless (find pattern done-elements
)
481 (push pattern done-elements
)
482 (setf (pattern-child pattern
)
483 (intern-pattern (pattern-child pattern
) table
)))))
486 ;;; FIXME: misnamed. we don't really intern the originals pattern yet.
488 (defgeneric intern-pattern
(pattern table
))
490 (defmethod intern-pattern ((pattern element
) table
)
491 (pushnew pattern
*seen-elements
*)
494 (defmethod intern-pattern :around
((pattern pattern
) table
)
495 (finalize-pattern (call-next-method)))
497 (defmethod intern-pattern ((pattern %parent
) table
)
498 (let ((c (intern-pattern (pattern-child pattern
) table
)))
499 (if (eq c
(pattern-child pattern
))
501 (let ((copy (copy-structure pattern
)))
502 (setf (pattern-child copy
) c
)
505 (defmethod intern-pattern ((pattern %combination
) table
)
506 (let ((a (intern-pattern (pattern-a pattern
) table
))
507 (b (intern-pattern (pattern-b pattern
) table
)))
508 (if (and (eq a
(pattern-a pattern
)) (eq b
(pattern-b pattern
)))
510 (let ((copy (copy-structure pattern
)))
511 (setf (pattern-a copy
) a
)
512 (setf (pattern-b copy
) b
)
515 (defmethod intern-pattern ((pattern data
) table
)
516 (let ((e (when (pattern-except pattern
)
517 (intern-pattern (pattern-except pattern
) table
))))
518 (if (eq e
(pattern-except pattern
))
520 (let ((copy (copy-structure pattern
)))
521 (setf (pattern-except copy
) e
)
524 (defmethod intern-pattern ((pattern ref
) table
)
525 (intern-pattern (defn-child (pattern-target pattern
)) table
))
527 (defmethod intern-pattern ((pattern empty
) table
)
530 (defmethod intern-pattern ((pattern not-allowed
) table
)
533 (defmethod intern-pattern ((pattern %leaf
) table
)
539 (defgeneric apply-after
(handler fn pattern
))
541 (defmethod apply-after (hsx fn
(pattern after
))
544 (funcall fn
(pattern-b pattern
))))
546 (defmethod apply-after (hsx fn
(pattern choice
))
548 (apply-after hsx fn
(pattern-a pattern
))
549 (apply-after hsx fn
(pattern-b pattern
))))
551 (defmethod apply-after (hsx fn
(pattern not-allowed
))
552 (declare (ignore hsx fn
))
558 (defgeneric open-start-tag
\' (handler pattern uri lname
))
560 (defmethod open-start-tag\' :around
(hsx (pattern pattern
) uri lname
)
561 (ensuref (list pattern uri lname
)
562 (open-start-tag\'-cache hsx
)
565 (defmethod open-start-tag\' (hsx (pattern choice
) uri lname
)
567 (open-start-tag\' hsx
(pattern-a pattern
) uri lname
)
568 (open-start-tag\' hsx
(pattern-b pattern
) uri lname
)))
570 (defmethod open-start-tag\' (hsx (pattern element
) uri lname
)
571 (if (contains (pattern-name pattern
) (or uri
"") lname
)
572 (intern-after hsx
(pattern-child pattern
) *empty
*)
575 (defmethod open-start-tag\' (hsx (pattern interleave
) uri lname
)
579 (lambda (p) (intern-interleave hsx p
(pattern-b pattern
)))
580 (open-start-tag\' hsx
(pattern-a pattern
) uri lname
))
583 (lambda (p) (intern-interleave hsx
(pattern-a pattern
) p
))
584 (open-start-tag\' hsx
(pattern-b pattern
) uri lname
))))
586 (defun intern-zero-or-more (hsx c
)
587 (intern-choice hsx
(intern-one-or-more hsx c
) *empty
*))
589 (defmethod open-start-tag\' (hsx (pattern one-or-more
) uri lname
)
590 (let ((c (intern-zero-or-more hsx
(pattern-child pattern
))))
592 (lambda (p) (intern-group hsx p c
))
593 (open-start-tag\' hsx
(pattern-child pattern
) uri lname
))))
595 (defmethod open-start-tag\' (hsx (pattern group
) uri lname
)
596 (let ((x (apply-after hsx
598 (intern-group hsx p
(pattern-b pattern
)))
599 (open-start-tag\' hsx
(pattern-a pattern
) uri lname
))))
600 (if (nullable (pattern-a pattern
))
603 (open-start-tag\' hsx
(pattern-b pattern
) uri lname
))
606 (defmethod open-start-tag\' (hsx (pattern after
) uri lname
)
609 (intern-after hsx p
(pattern-b pattern
)))
610 (open-start-tag\' hsx
(pattern-a pattern
) uri lname
)))
612 (defmethod open-start-tag\' (hsx pattern uri lname
)
613 (declare (ignore hsx pattern uri lname
))
619 (defun attributes\' (handler pattern attributes
)
620 (dolist (a attributes
)
621 (setf pattern
(attribute\' handler pattern a
)))
624 (defgeneric attribute
\' (handler pattern attribute
))
626 (defmethod attribute\' (hsx (pattern after
) a
)
628 (attribute\' hsx
(pattern-a pattern
) a
)
629 (pattern-b pattern
)))
631 (defmethod attribute\' (hsx (pattern choice
) a
)
633 (attribute\' hsx
(pattern-a pattern
) a
)
634 (attribute\' hsx
(pattern-b pattern
) a
)))
636 (defmethod attribute\' (hsx (pattern group
) a
)
639 (attribute\' hsx
(pattern-a pattern
) a
)
643 (attribute\' hsx
(pattern-b pattern
) a
))))
645 (defmethod attribute\' (hsx (pattern interleave
) a
)
647 (intern-interleave hsx
648 (attribute\' hsx
(pattern-a pattern
) a
)
650 (intern-interleave hsx
652 (attribute\' hsx
(pattern-b pattern
) a
))))
654 (defmethod attribute\' (hsx (pattern one-or-more
) a
)
656 (attribute\' hsx
(pattern-child pattern
) a
)
657 (intern-zero-or-more hsx
(pattern-child pattern
))))
659 (defmethod attribute\' (hsx (pattern attribute
) a
)
660 (eat (and (contains (pattern-name pattern
)
661 (or (sax:attribute-namespace-uri a
) "")
662 (sax:attribute-local-name a
))
664 (pattern-child pattern
)
665 (sax:attribute-value a
)))))
667 (defun value-matches-p (hsx pattern value
)
668 (or (and (nullable pattern
) (whitespacep value
))
669 (nullable (text-only\' hsx pattern value
))))
671 (defun whitespacep (str)
672 (zerop (length (string-trim *whitespace
* str
))))
674 (defmethod attribute\' (hsx pattern a
)
675 (declare (ignore hsx pattern a
))
679 ;;;; CLOSE-START-TAG'
681 (defgeneric close-start-tag
\' (handler pattern
))
683 (defmethod close-start-tag\' :around
(hsx (pattern pattern
))
684 (ensuref pattern
(close-start-tag\'-cache hsx
) (call-next-method)))
686 (defmethod close-start-tag\' (hsx (pattern after
))
688 (close-start-tag\' hsx
(pattern-a pattern
))
689 (pattern-b pattern
)))
691 (defmethod close-start-tag\' (hsx (pattern choice
))
693 (close-start-tag\' hsx
(pattern-a pattern
))
694 (close-start-tag\' hsx
(pattern-b pattern
))))
696 (defmethod close-start-tag\' (hsx (pattern group
))
698 (close-start-tag\' hsx
(pattern-a pattern
))
699 (close-start-tag\' hsx
(pattern-b pattern
))))
701 (defmethod close-start-tag\' (hsx (pattern interleave
))
702 (intern-interleave hsx
703 (close-start-tag\' hsx
(pattern-a pattern
))
704 (close-start-tag\' hsx
(pattern-b pattern
))))
706 (defmethod close-start-tag\' (hsx (pattern one-or-more
))
707 (intern-one-or-more hsx
(close-start-tag\' hsx
(pattern-child pattern
))))
709 (defmethod close-start-tag\' (hsx (pattern attribute
))
710 (declare (ignore hsx
))
713 (defmethod close-start-tag\' (hsx pattern
)
714 (declare (ignore hsx
))
720 (defgeneric end-tag
\' (handler pattern
))
722 (defmethod end-tag\' :around
(hsx (pattern pattern
))
723 (ensuref pattern
(end-tag\'-cache hsx
) (call-next-method)))
725 (defmethod end-tag\' (hsx (pattern choice
))
727 (end-tag\' hsx
(pattern-a pattern
))
728 (end-tag\' hsx
(pattern-b pattern
))))
730 (defmethod end-tag\' (hsx (pattern after
))
731 (if (nullable (pattern-a pattern
))
735 (defmethod end-tag\' (hsx pattern
)
736 (declare (ignore hsx pattern
))
742 ;;; FIXME: cxml should do that
744 ;;; FIXME: since we ignore PI, CDATA, and comment events, we should probably
745 ;;; discard them properly.
747 (defclass text-normalizer
(cxml:sax-proxy
)
748 ((pending-text-node :initform
(make-string-output-stream)
749 :accessor pending-text-node
)))
751 (defmethod sax:characters
((handler text-normalizer
) data
)
752 (write-string data
(pending-text-node handler
)))
754 (defun flush-pending (handler)
755 (let ((str (get-output-stream-string (pending-text-node handler
))))
756 (unless (zerop (length str
))
757 (sax:characters
(cxml:proxy-chained-handler handler
) str
))))
759 (defmethod sax:start-element
:before
760 ((handler text-normalizer
) uri lname qname attributes
)
761 (declare (ignore uri lname qname attributes
))
762 (flush-pending handler
))
764 (defmethod sax:end-element
:before
765 ((handler text-normalizer
) uri lname qname
)
766 (declare (ignore uri lname qname
))
767 (flush-pending handler
))
770 ;;;; EXPECTATION, DESCRIBE-NAME
772 (defgeneric expectation
(pattern stream
))
773 (defgeneric describe-name
(name-class stream
))
775 (defmethod expectation ((pattern after
) s
)
776 (expectation (pattern-a pattern
) s
))
778 (defmethod expectation ((pattern group
) s
)
779 (expectation (pattern-a pattern
) s
))
781 (defmethod expectation ((pattern attribute
) s
)
782 (write-string "an attribute " s
)
783 (describe-name (pattern-name pattern
) s
)
784 (format s
"~% with a value of ")
785 (expectation (pattern-child pattern
) s
))
787 (defmethod expectation ((pattern choice
) s
)
788 (expectation (pattern-a pattern
) s
)
790 (expectation (pattern-b pattern
) s
))
792 (defmethod expectation ((pattern element
) s
)
793 (write-string "an element " s
)
794 (describe-name (pattern-name pattern
) s
))
796 (defmethod expectation ((pattern data
) s
)
797 (format s
"a text node of type ~A" (pattern-type pattern
)))
799 (defmethod expectation ((pattern interleave
) s
)
800 (expectation (pattern-a pattern
) s
)
801 (format s
"~% interleaved with ")
802 (expectation (pattern-b pattern
) s
))
804 (defmethod expectation ((pattern list-pattern
) s
)
805 (format s
"a whitespace separated list of:~% ")
806 (expectation (pattern-child pattern
) s
))
808 (defmethod expectation ((pattern not-allowed
) s
)
809 "nothing is allowed here at all")
811 (defmethod expectation ((pattern one-or-more
) s
)
812 (format s
"one or more of:~% ")
813 (expectation (pattern-child pattern
) s
))
815 (defmethod expectation ((pattern text
) s
)
818 (defmethod expectation ((pattern value
) s
)
819 (format s
"a text node of type ~A and value ~S"
820 (pattern-type pattern
)
821 (pattern-value pattern
)))
823 (defmethod expectation ((pattern empty
) s
)
824 (write-string "nothing more" s
))
826 (defmethod describe-name ((nc name
) s
)
827 (format s
"named ~S, in the namespace ~S"
831 (defmethod describe-name ((nc any-name
) s
)
832 (write-string "of any name" s
)
833 (when (any-name-except nc
)
834 (write-string " except " s
)
835 (describe-name (any-name-except nc
) s
)))
837 (defmethod describe-name ((nc ns-name
) s
)
838 (format s
"with a name in the namespace ~S" (ns-name-uri nc
))
839 (when (ns-name-except nc
)
840 (write-string " except for " s
)
841 (describe-name (ns-name-except nc
) s
)))
843 (defmethod describe-name ((nc name-class-choice
) s
)
844 (describe-name (name-class-choice-a nc
) s
)
846 (describe-name (name-class-choice-b nc
) s
))
851 (finalize-pattern *empty
*)
852 (finalize-pattern *not-allowed
*)