base64 und hex
[cxml-rng.git] / validate.lisp
blobd0bf58057ed432196ae84089010b869bb96def11
1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
2 ;;;
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
8 ;;; are met:
9 ;;;
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
12 ;;;
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.
17 ;;;
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.
53 @see{parse-schema}"
54 (let* ((table (ensure-registratur schema))
55 (start (schema-interned-start schema))
56 (validator
57 (make-instance 'validator
58 :registratur table
59 :current-pattern start)))
60 (make-instance 'text-normalizer :chained-handler validator)))
63 ;;;; CONTAINS
65 (defgeneric contains (nc uri lname))
67 (defmethod contains ((nc any-name) uri lname)
68 (let ((except (any-name-except nc)))
69 (if except
70 (not (contains except uri lname))
71 t)))
73 (defmethod contains ((nc ns-name) uri lname)
74 (and (equal (ns-name-uri nc) uri)
75 (let ((except (ns-name-except nc)))
76 (if except
77 (not (contains except uri lname))
78 t))))
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)))
89 ;;;; COMPUTE-NULLABLE
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
98 np))
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)
129 ;;;; VALIDATOR
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"
150 message
151 args
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
160 :circle t
161 :escape nil
162 :pretty nil)))
163 (loop
164 for c across str
165 for i from 0
166 when (>= (char-code c) 128)
167 do (setf (elt str i) #\?))
168 str))
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
176 (advance hsx
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)
188 (advance hsx
189 (mixed-text\' hsx (current-pattern hsx))
190 "text node")))
191 (setf (pending-text-node hsx) nil))
192 (setf attributes
193 (remove-if (cxml::compose #'cxml::xmlns-attr-p #'sax:attribute-qname)
194 attributes))
195 (let* ((p0 (current-pattern hsx))
196 (p1 (open-start-tag\' hsx p0 uri lname))
197 (p2 (progn
198 (advance hsx p1 "element ~A (~A) not valid" lname uri)
199 (attributes\' hsx p1 attributes)))
200 (p3 (progn
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)))
217 (advance hsx
218 (if (whitespacep data)
219 (intern-choice hsx current next)
220 next)
221 "text node not valid"))
222 (setf (pending-text-node hsx) nil))
223 (advance hsx
224 (end-tag\' hsx (current-pattern hsx))
225 "end of element not valid"))
227 (defun eat (ok)
228 (if ok *empty* *not-allowed*))
231 ;;;; TEXT-ONLY' / NON-ELEMENT'
233 (defun text-only\' (handler pattern data)
234 (data\' handler
235 (non-element\' handler pattern)
236 data))
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))
244 (intern-choice hsx
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)))
251 (intern-choice hsx
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)))
259 (if (nullable a)
260 (intern-choice hsx p (non-element\' hsx b))
261 p)))
263 (defmethod non-element\' (hsx (pattern after))
264 (intern-after hsx
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)))
270 (intern-group hsx
271 (non-element\' hsx child)
272 (intern-zero-or-more hsx child))))
274 (defmethod non-element\' (hsx (pattern element))
275 *not-allowed*)
277 (defmethod non-element\' (hsx pattern)
278 pattern)
281 ;;;; DATA'
283 (defgeneric data\' (handler pattern data))
285 (defmethod data\' (hsx (pattern choice) data)
286 (intern-choice hsx
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)))
293 (intern-choice hsx
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)))
301 (if (nullable a)
302 (intern-choice hsx p (data\' hsx b data))
303 p)))
305 (defmethod data\' (hsx (pattern after) data)
306 (intern-after hsx
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)))
312 (intern-group hsx
313 (data\' hsx child data)
314 (intern-zero-or-more hsx child))))
316 (defmethod data\' (hsx (pattern text) data)
317 (declare (ignore data))
318 pattern)
320 (defmethod data\' (hsx (pattern value) data)
321 (let ((data-type (pattern-type pattern)))
322 (eat (cxml-types:equal-using-type
323 data-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))
337 *not-allowed*)
339 (defun list\' (hsx pattern words)
340 (dolist (word words)
341 (setf pattern (data\' hsx pattern word)))
342 pattern)
344 (defun words (str)
345 (cl-ppcre:split #.(format nil "[~A]+" *whitespace*)
346 (string-trim *whitespace* str)))
349 ;;;; MIXED-TEXT'
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))
357 (intern-choice hsx
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)))
364 (intern-choice hsx
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)))
372 (if (nullable a)
373 (intern-choice hsx p (mixed-text\' hsx b))
374 p)))
376 (defmethod mixed-text\' (hsx (pattern after))
377 (intern-after hsx
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)))
383 (intern-group hsx
384 (mixed-text\' hsx child)
385 (intern-zero-or-more hsx child))))
387 (defmethod mixed-text\' (hsx (pattern text))
388 pattern)
390 (defmethod mixed-text\' (hsx pattern)
391 (declare (ignore pattern))
392 *not-allowed*)
395 ;;;; INTERN
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)
402 (registratur hsx)
403 (let ((table (make-hash-table)))
404 (labels ((record (p)
405 (cond
406 ((typep p 'choice)
407 (record (pattern-a p))
408 (record (pattern-b p)))
410 (setf (gethash p table) t)))))
411 (record a))
412 (labels ((eliminate (p)
413 (cond
414 ((typep p 'choice)
415 (intern-choice hsx
416 (eliminate (pattern-a p))
417 (eliminate (pattern-b p))))
418 ((gethash p table)
419 *not-allowed*)
421 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)
434 (registratur hsx)
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)
444 (registratur hsx)
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)
452 (registratur hsx)
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)
459 (registratur hsx)
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* '())
472 (done-elements '()))
473 (setf (schema-interned-start grammar)
474 (intern-pattern (schema-start grammar) table))
475 (loop
476 for elements = *seen-elements*
477 while elements do
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)))))
484 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*)
492 pattern)
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))
500 pattern
501 (let ((copy (copy-structure pattern)))
502 (setf (pattern-child copy) c)
503 copy))))
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)))
509 pattern
510 (let ((copy (copy-structure pattern)))
511 (setf (pattern-a copy) a)
512 (setf (pattern-b copy) b)
513 copy))))
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))
519 pattern
520 (let ((copy (copy-structure pattern)))
521 (setf (pattern-except copy) e)
522 copy))))
524 (defmethod intern-pattern ((pattern ref) table)
525 (intern-pattern (defn-child (pattern-target pattern)) table))
527 (defmethod intern-pattern ((pattern empty) table)
528 *empty*)
530 (defmethod intern-pattern ((pattern not-allowed) table)
531 *not-allowed*)
533 (defmethod intern-pattern ((pattern %leaf) table)
534 pattern)
537 ;;;; APPLY-AFTER
539 (defgeneric apply-after (handler fn pattern))
541 (defmethod apply-after (hsx fn (pattern after))
542 (intern-after hsx
543 (pattern-a pattern)
544 (funcall fn (pattern-b pattern))))
546 (defmethod apply-after (hsx fn (pattern choice))
547 (intern-choice hsx
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))
553 pattern)
556 ;;;; OPEN-START-TAG'
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)
563 (call-next-method)))
565 (defmethod open-start-tag\' (hsx (pattern choice) uri lname)
566 (intern-choice hsx
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*)
573 *not-allowed*))
575 (defmethod open-start-tag\' (hsx (pattern interleave) uri lname)
576 (intern-choice hsx
577 (apply-after
579 (lambda (p) (intern-interleave hsx p (pattern-b pattern)))
580 (open-start-tag\' hsx (pattern-a pattern) uri lname))
581 (apply-after
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))))
591 (apply-after hsx
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
597 (lambda (p)
598 (intern-group hsx p (pattern-b pattern)))
599 (open-start-tag\' hsx (pattern-a pattern) uri lname))))
600 (if (nullable (pattern-a pattern))
601 (intern-choice hsx
603 (open-start-tag\' hsx (pattern-b pattern) uri lname))
604 x)))
606 (defmethod open-start-tag\' (hsx (pattern after) uri lname)
607 (apply-after hsx
608 (lambda (p)
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))
614 *not-allowed*)
617 ;;;; ATTRIBUTES'
619 (defun attributes\' (handler pattern attributes)
620 (dolist (a attributes)
621 (setf pattern (attribute\' handler pattern a)))
622 pattern)
624 (defgeneric attribute\' (handler pattern attribute))
626 (defmethod attribute\' (hsx (pattern after) a)
627 (intern-after hsx
628 (attribute\' hsx (pattern-a pattern) a)
629 (pattern-b pattern)))
631 (defmethod attribute\' (hsx (pattern choice) a)
632 (intern-choice hsx
633 (attribute\' hsx (pattern-a pattern) a)
634 (attribute\' hsx (pattern-b pattern) a)))
636 (defmethod attribute\' (hsx (pattern group) a)
637 (intern-choice hsx
638 (intern-group hsx
639 (attribute\' hsx (pattern-a pattern) a)
640 (pattern-b pattern))
641 (intern-group hsx
642 (pattern-a pattern)
643 (attribute\' hsx (pattern-b pattern) a))))
645 (defmethod attribute\' (hsx (pattern interleave) a)
646 (intern-choice hsx
647 (intern-interleave hsx
648 (attribute\' hsx (pattern-a pattern) a)
649 (pattern-b pattern))
650 (intern-interleave hsx
651 (pattern-a pattern)
652 (attribute\' hsx (pattern-b pattern) a))))
654 (defmethod attribute\' (hsx (pattern one-or-more) a)
655 (intern-group hsx
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))
663 (value-matches-p hsx
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))
676 *not-allowed*)
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))
687 (intern-after hsx
688 (close-start-tag\' hsx (pattern-a pattern))
689 (pattern-b pattern)))
691 (defmethod close-start-tag\' (hsx (pattern choice))
692 (intern-choice hsx
693 (close-start-tag\' hsx (pattern-a pattern))
694 (close-start-tag\' hsx (pattern-b pattern))))
696 (defmethod close-start-tag\' (hsx (pattern group))
697 (intern-group hsx
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))
711 *not-allowed*)
713 (defmethod close-start-tag\' (hsx pattern)
714 (declare (ignore hsx))
715 pattern)
718 ;;;; END-TAG\'
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))
726 (intern-choice hsx
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))
732 (pattern-b pattern)
733 *not-allowed*))
735 (defmethod end-tag\' (hsx pattern)
736 (declare (ignore hsx pattern))
737 *not-allowed*)
740 ;;;; TEXT NORMALIZER
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))
785 (defmethod expectation ((pattern choice) s)
786 (expectation (pattern-a pattern) s)
787 (format s "~% or ")
788 (expectation (pattern-b pattern) s))
790 (defmethod expectation ((pattern element) s)
791 (write-string "an element " s)
792 (describe-name (pattern-name pattern) s))
794 (defmethod expectation ((pattern data) s)
795 (format s "a text node of type ~A" (pattern-type pattern)))
797 (defmethod expectation ((pattern interleave) s)
798 (expectation (pattern-a pattern) s)
799 (format s "~% interleaved with ")
800 (expectation (pattern-b pattern) s))
802 (defmethod expectation ((pattern list-pattern) s)
803 (format s "a whitespace separated list of:~% ")
804 (expectation (pattern-child pattern) s))
806 (defmethod expectation ((pattern not-allowed) s)
807 "nothing is allowed here at all")
809 (defmethod expectation ((pattern one-or-more) s)
810 (format s "one or more of:~% ")
811 (expectation (pattern-child pattern) s))
813 (defmethod expectation ((pattern text) s)
814 "whitespace")
816 (defmethod expectation ((pattern value) s)
817 (format s "a text node of type ~A and value ~S"
818 (pattern-type pattern)
819 (pattern-value pattern)))
821 (defmethod expectation ((pattern empty) s)
822 (write-string "nothing more" s))
824 (defmethod describe-name ((nc name) s)
825 (format s "named ~S, in the namespace ~S"
826 (name-lname nc)
827 (name-uri nc)))
829 (defmethod describe-name ((nc any-name) s)
830 (write-string "of any name" s)
831 (when (any-name-except nc)
832 (write-string " except " s)
833 (describe-name (any-name-except nc) s)))
835 (defmethod describe-name ((nc ns-name) s)
836 (format s "with a name in the namespace ~S" (ns-name-uri nc))
837 (when (ns-name-except nc)
838 (write-string " except for " s)
839 (describe-name (ns-name-except nc) s)))
841 (defmethod describe-name ((nc name-class-choice) s)
842 (describe-name (name-class-choice-a nc) s)
843 (format s "~% or ")
844 (describe-name (name-class-choice-b nc) s))
847 ;;;;
849 (finalize-pattern *empty*)
850 (finalize-pattern *not-allowed*)