validate.lisp

   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.
   5
   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.
  29
  30
  31 (in-package :cxml-rng)
  32
  33 (defvar *empty* (make-empty))
  34 (defvar *not-allowed* (make-not-allowed))
  35
  36 (defmacro ensuref (key table value)
  37   `(ensure-hash ,key ,table (lambda () ,value)))
  38
  39 (defun ensure-hash (key table fn)
  40   (or (gethash key table)
  41       (setf (gethash key table) (funcall fn))))
  42
  43
  44 (defun make-validator (schema &optional handler)
  45   "@arg[schema]{the parsed Relax NG @class{schema} object}
  46    @arg[handler]{an additional SAX handler to broadcast events to}
  47    @return{a SAX handler}
  48    @short{This function creates a validation handler for @code{schema}},
  49     to be used for validation of a document against that schema.
  50
  51    The validation handler processes SAX events and can be used with any
  52    function generating such events, in particular with cxml:parse-file.
  53
  54    Events will be passed on unchanged to @code{handler}.
  55
  56    This validator does @em{not} perform DTD compatibility processing.
  57    (Specify a DTD compatibility handler as the second argument to this
  58    function instead.)
  59
  60    @see{parse-schema}
  61    @see{make-validating-source}
  62    @see{make-dtd-compatibility-handler}"
  63   (let* ((table (ensure-registratur schema))
  64          (start (schema-interned-start schema))
  65          (validator
  66           (make-instance 'validator
  67                          :registratur table
  68                          :current-pattern start))
  69          (wrapper
  70           (make-instance 'text-normalizer :chained-handler validator)))
  71     (when handler
  72       (setf wrapper (cxml:make-broadcast-handler wrapper handler)))
  73     (values wrapper validator)))
  74
  75 (defun make-dtd-compatibility-handler (schema handler)
  76   "@arg[schema]{the parsed Relax NG @class{schema} object}
  77    @arg[handler]{an additional SAX handler to broadcast events to}
  78    @return{a SAX handler}
  79    @short{This function creates a handler for DTD Compatibility processing}
  80    according to @code{schema}.
  81
  82    The validation handler processes SAX events and can be used with any
  83    function generating such events, in particular with cxml:parse-file.
  84
  85    Compatibility processing consists of two steps: Infoset modification
  86    for default values, and soundness checking for attributes with an
  87    ID-type.
  88
  89    In @code{sax:start-element}, infoset modification will be performed as
  90    specified for DTD compatibility.  This entails addition of attributes
  91    according to their defaultValue, and addition (and, when the element ends,
  92    removal) of suitable namespace declarations if no prefix has been declared
  93    for the defaulted attribute yet.
  94
  95    Also in @code{sax:start-element}, the handler checks that no ID is declared
  96    more than once.  Before the end of the document, the handler checks that
  97    all IDs referred to by attributes with ID-types IDREF or IDREFS have been
  98    declared.
  99
 100    @see{parse-schema}
 101    @see{make-validator}"
 102   (make-instance 'dtd-compatibility-handler
 103                  :compatibility-table (schema-compatibility-table schema)
 104                  :handlers (list handler)))
 105
 106
 107 ;;;; CONTAINS
 108
 109 (defgeneric contains (nc uri lname))
 110
 111 (defmethod contains ((nc any-name) uri lname)
 112   (let ((except (any-name-except nc)))
 113     (if except
 114         (not (contains except uri lname))
 115         t)))
 116
 117 (defmethod contains ((nc ns-name) uri lname)
 118   (and (equal (ns-name-uri nc) uri)
 119        (let ((except (ns-name-except nc)))
 120          (if except
 121              (not (contains except uri lname))
 122              t))))
 123
 124 (defmethod contains ((nc name) uri lname)
 125   (and (equal (name-uri nc) uri)
 126        (equal (name-lname nc) lname)))
 127
 128 (defmethod contains ((nc name-class-choice) uri lname)
 129   (or (contains (name-class-choice-a nc) uri lname)
 130       (contains (name-class-choice-b nc) uri lname)))
 131
 132
 133 ;;;; COMPUTE-NULLABLE
 134
 135 (defun finalize-pattern (p)
 136   (setf (pattern-nullable p) (compute-nullable p))
 137   p)
 138
 139 (defun nullable (pattern)
 140   (let ((np (pattern-nullable pattern)))
 141     (check-type np boolean)             ;initialized by intern-pattern
 142     np))
 143
 144 (defgeneric compute-nullable (pattern))
 145
 146 (defmethod compute-nullable ((pattern group))
 147   (and (nullable (pattern-a pattern))
 148        (nullable (pattern-b pattern))))
 149
 150 (defmethod compute-nullable  ((pattern interleave))
 151   (and (nullable (pattern-a pattern))
 152        (nullable (pattern-b pattern))))
 153
 154 (defmethod compute-nullable ((pattern choice))
 155   (or (nullable (pattern-a pattern))
 156       (nullable (pattern-b pattern))))
 157
 158 (defmethod compute-nullable ((pattern one-or-more))
 159   (nullable (pattern-child pattern)))
 160
 161 (defmethod compute-nullable ((pattern element)) nil)
 162 (defmethod compute-nullable ((pattern attribute)) nil)
 163 (defmethod compute-nullable ((pattern list-pattern)) nil)
 164 (defmethod compute-nullable ((pattern value)) nil)
 165 (defmethod compute-nullable ((pattern data)) nil)
 166 (defmethod compute-nullable ((pattern not-allowed)) nil)
 167 (defmethod compute-nullable ((pattern after)) nil)
 168
 169 (defmethod compute-nullable ((pattern empty)) t)
 170 (defmethod compute-nullable ((pattern text)) t)
 171
 172
 173 ;;;; VALIDATOR
 174
 175 (defclass validator (sax:default-handler
 176                      cxml-types:sax-validation-context-mixin)
 177   ((current-pattern :initarg :current-pattern :accessor current-pattern)
 178    (after-start-tag-p :accessor after-start-tag-p)
 179    (pending-text-node :initform nil :accessor pending-text-node)
 180    (registratur :initarg :registratur :accessor registratur)
 181    (validation-error-class :initform 'rng-error
 182                            :initarg :validation-error-class
 183                            :accessor validation-error-class)
 184    (open-start-tag\'-cache :initform (make-hash-table :test 'equal)
 185                            :reader open-start-tag\'-cache)
 186    (close-start-tag\'-cache :initform (make-hash-table)
 187                             :reader close-start-tag\'-cache)
 188    (end-tag\'-cache :initform (make-hash-table) :reader end-tag\'-cache)
 189    (non-element\'-cache :initform (make-hash-table)
 190                         :reader non-element\'-cache)
 191    (mixed-text\'-cache :initform (make-hash-table)
 192                        :reader mixed-text\'-cache)))
 193
 194 (defun advance (hsx pattern message &rest args)
 195   (when (typep pattern 'not-allowed)
 196     (let ((*error-class* (validation-error-class hsx)))
 197       (rng-error hsx "~?,~%was expecting ~A"
 198                  message
 199                  args
 200                  (replace-scary-characters
 201                   (with-output-to-string (s)
 202                     (let ((*print-level* nil))
 203                       (expectation (current-pattern hsx) s)))))))
 204   (setf (current-pattern hsx) pattern))
 205
 206 ;; make sure slime doesn't die
 207 (defun replace-scary-characters (pattern)
 208   (let ((str (write-to-string pattern
 209                               :circle t
 210                               :escape nil
 211                               :pretty nil)))
 212     (loop
 213        for c across str
 214        for i from 0
 215        when (>= (char-code c) 128)
 216        do (setf (elt str i) #\?))
 217     str))
 218
 219 (defmethod sax:characters ((hsx validator) data)
 220   (assert (null (pending-text-node hsx))) ;parser must be normalize
 221   (if (after-start-tag-p hsx)
 222       (setf (pending-text-node hsx) data)
 223       (unless (whitespacep data)
 224         ;; we already saw an element sibling, so discard whitespace
 225         (advance hsx
 226                  (mixed-text\' hsx (current-pattern hsx))
 227                  "text node not valid")))
 228   (setf (after-start-tag-p hsx) nil))
 229
 230 (defmethod sax:start-element ((hsx validator) uri lname qname attributes)
 231   (declare (ignore qname))
 232   (when (pending-text-node hsx)
 233     ;; text node was the previous child, and we're in element content.
 234     ;; process non-whitespace now; discard whitespace completely
 235     (let ((data (pending-text-node hsx)))
 236       (unless (whitespacep data)
 237         (advance hsx
 238                  (mixed-text\' hsx (current-pattern hsx))
 239                  "text node")))
 240     (setf (pending-text-node hsx) nil))
 241   (setf attributes
 242         (remove-if (cxml::compose #'cxml::xmlns-attr-p #'sax:attribute-qname)
 243                    attributes))
 244   (let* ((p0 (current-pattern hsx))
 245          (p1 (open-start-tag\' hsx p0 uri lname))
 246          (p2 (progn
 247                (advance hsx p1 "element ~A (~A) not valid" lname uri)
 248                (attributes\' hsx p1 attributes)))
 249          (p3 (progn
 250                (advance hsx p2 "attributes not valid")
 251                (close-start-tag\' hsx p2))))
 252     (advance hsx p3 "attributes not valid")
 253     (setf (after-start-tag-p hsx) t)))
 254
 255 (defmethod sax:end-element ((hsx validator) uri lname qname)
 256   (declare (ignore uri lname qname))
 257   (when (after-start-tag-p hsx)
 258     ;; nothing at all?  pretend we saw whitespace.
 259     (sax:characters hsx ""))
 260   (when (pending-text-node hsx)
 261     ;; text node was the only child?
 262     ;; process it and handle whitespace specially
 263     (let* ((current (current-pattern hsx))
 264            (data (pending-text-node hsx))
 265            (next (text-only\' hsx current data)))
 266       (advance hsx
 267                (if (whitespacep data)
 268                    (intern-choice hsx current next)
 269                    next)
 270                "text node not valid"))
 271     (setf (pending-text-node hsx) nil))
 272   (advance hsx
 273            (end-tag\' hsx (current-pattern hsx))
 274            "end of element not valid"))
 275
 276 (defun eat (ok)
 277   (if ok *empty* *not-allowed*))
 278
 279
 280 ;;;; TEXT-ONLY' / NON-ELEMENT'
 281
 282 (defun text-only\' (handler pattern data)
 283   (data\' handler
 284           (non-element\' handler pattern)
 285           data))
 286
 287 (defgeneric non-element\' (handler pattern))
 288
 289 (defmethod non-element\' :around (hsx (pattern pattern))
 290   (ensuref pattern (non-element\'-cache hsx) (call-next-method)))
 291
 292 (defmethod non-element\' (hsx (pattern choice))
 293   (intern-choice hsx
 294                  (non-element\' hsx (pattern-a pattern))
 295                  (non-element\' hsx (pattern-b pattern))))
 296
 297 (defmethod non-element\' (hsx (pattern interleave))
 298   (let ((a (pattern-a pattern))
 299         (b (pattern-b pattern)))
 300     (intern-choice hsx
 301                    (intern-interleave hsx (non-element\' hsx a) b)
 302                    (intern-interleave hsx a (non-element\' hsx b)))))
 303
 304 (defmethod non-element\' (hsx (pattern group))
 305   (let* ((a (pattern-a pattern))
 306          (b (pattern-b pattern))
 307          (p (intern-group hsx (non-element\' hsx a) b)))
 308     (if (nullable a)
 309         (intern-choice hsx p (non-element\' hsx b))
 310         p)))
 311
 312 (defmethod non-element\' (hsx (pattern after))
 313   (intern-after hsx
 314                 (non-element\' hsx (pattern-a pattern))
 315                 (pattern-b pattern)))
 316
 317 (defmethod non-element\' (hsx (pattern one-or-more))
 318   (let ((child (pattern-child pattern)))
 319     (intern-group hsx
 320                   (non-element\' hsx child)
 321                   (intern-zero-or-more hsx child))))
 322
 323 (defmethod non-element\' (hsx (pattern element))
 324   *not-allowed*)
 325
 326 (defmethod non-element\' (hsx pattern)
 327   pattern)
 328
 329
 330 ;;;; DATA'
 331
 332 (defgeneric data\' (handler pattern data))
 333
 334 (defmethod data\' (hsx (pattern choice) data)
 335   (intern-choice hsx
 336                  (data\' hsx (pattern-a pattern) data)
 337                  (data\' hsx (pattern-b pattern) data)))
 338
 339 (defmethod data\' (hsx (pattern interleave) data)
 340   (let ((a (pattern-a pattern))
 341         (b (pattern-b pattern)))
 342     (intern-choice hsx
 343                    (intern-interleave hsx (data\' hsx a data) b)
 344                    (intern-interleave hsx a (data\' hsx b data)))))
 345
 346 (defmethod data\' (hsx (pattern group) data)
 347   (let* ((a (pattern-a pattern))
 348          (b (pattern-b pattern))
 349          (p (intern-group hsx (data\' hsx a data) b)))
 350     (if (nullable a)
 351         (intern-choice hsx p (data\' hsx b data))
 352         p)))
 353
 354 (defmethod data\' (hsx (pattern after) data)
 355   (intern-after hsx
 356                 (data\' hsx (pattern-a pattern) data)
 357                 (pattern-b pattern)))
 358
 359 (defmethod data\' (hsx (pattern one-or-more) data)
 360   (let ((child (pattern-child pattern)))
 361     (intern-group hsx
 362                   (data\' hsx child data)
 363                   (intern-zero-or-more hsx child))))
 364
 365 (defmethod data\' (hsx (pattern text) data)
 366   (declare (ignore data))
 367   pattern)
 368
 369 (defmethod data\' (hsx (pattern value) data)
 370   (let ((data-type (pattern-type pattern)))
 371     (eat (cxml-types:equal-using-type
 372           data-type
 373           (pattern-value pattern)
 374           (cxml-types:parse data-type data hsx)))))
 375
 376 (defmethod data\' (hsx (pattern data) data)
 377   (eat (and (cxml-types:validp (pattern-type pattern) data hsx)
 378             (let ((except (pattern-except pattern)))
 379               (not (and except (nullable (data\' hsx except data))))))))
 380
 381 (defmethod data\' (hsx (pattern list-pattern) data)
 382   (eat (nullable (list\' hsx (pattern-child pattern) (words data)))))
 383
 384 (defmethod data\' (hsx pattern data)
 385   (declare (ignore pattern data))
 386   *not-allowed*)
 387
 388 (defun list\' (hsx pattern words)
 389   (dolist (word words)
 390     (setf pattern (data\' hsx pattern word)))
 391   pattern)
 392
 393 (defun words (str)
 394   (cl-ppcre:split #.(format nil "[~A]+" *whitespace*)
 395                   (string-trim *whitespace* str)))
 396
 397
 398 ;;;; MIXED-TEXT'
 399
 400 (defgeneric mixed-text\' (handler pattern))
 401
 402 (defmethod mixed-text\' :around (hsx (pattern pattern))
 403   (ensuref pattern (mixed-text\'-cache hsx) (call-next-method)))
 404
 405 (defmethod mixed-text\' (hsx (pattern choice))
 406   (intern-choice hsx
 407                  (mixed-text\' hsx (pattern-a pattern))
 408                  (mixed-text\' hsx (pattern-b pattern))))
 409
 410 (defmethod mixed-text\' (hsx (pattern interleave))
 411   (let ((a (pattern-a pattern))
 412         (b (pattern-b pattern)))
 413     (intern-choice hsx
 414                    (intern-interleave hsx (mixed-text\' hsx a) b)
 415                    (intern-interleave hsx a (mixed-text\' hsx b)))))
 416
 417 (defmethod mixed-text\' (hsx (pattern group))
 418   (let* ((a (pattern-a pattern))
 419          (b (pattern-b pattern))
 420          (p (intern-group hsx (mixed-text\' hsx a) b)))
 421     (if (nullable a)
 422         (intern-choice hsx p (mixed-text\' hsx b))
 423         p)))
 424
 425 (defmethod mixed-text\' (hsx (pattern after))
 426   (intern-after hsx
 427                 (mixed-text\' hsx (pattern-a pattern))
 428                 (pattern-b pattern)))
 429
 430 (defmethod mixed-text\' (hsx (pattern one-or-more))
 431   (let ((child (pattern-child pattern)))
 432     (intern-group hsx
 433                   (mixed-text\' hsx child)
 434                   (intern-zero-or-more hsx child))))
 435
 436 (defmethod mixed-text\' (hsx (pattern text))
 437   pattern)
 438
 439 (defmethod mixed-text\' (hsx pattern)
 440   (declare (ignore pattern))
 441   *not-allowed*)
 442
 443
 444 ;;;; INTERN
 445
 446 (defgeneric intern-choice (handler a b))
 447 (defmethod intern-choice (hsx a (b not-allowed)) a)
 448 (defmethod intern-choice (hsx (a not-allowed) b) b)
 449 (defmethod intern-choice (hsx a b)
 450   (ensuref (list 'choice a b)
 451            (registratur hsx)
 452            (let ((table (make-hash-table)))
 453              (labels ((record (p)
 454                         (cond
 455                           ((typep p 'choice)
 456                            (record (pattern-a p))
 457                            (record (pattern-b p)))
 458                           (t
 459                            (setf (gethash p table) t)))))
 460                (record a))
 461              (labels ((eliminate (p)
 462                         (cond
 463                           ((typep p 'choice)
 464                            (intern-choice hsx
 465                                           (eliminate (pattern-a p))
 466                                           (eliminate (pattern-b p))))
 467                           ((gethash p table)
 468                            *not-allowed*)
 469                           (t
 470                            p))))
 471                (let ((x (eliminate b)))
 472                  (if (typep x 'not-allowed)
 473                      a
 474                      (finalize-pattern (make-choice a x))))))))
 475
 476 (defgeneric intern-group (handler a b))
 477 (defmethod intern-group (hsx (a pattern) (b not-allowed)) b)
 478 (defmethod intern-group (hsx (a not-allowed) (b pattern)) a)
 479 (defmethod intern-group (hsx a (b empty)) a)
 480 (defmethod intern-group (hsx (a empty) b) b)
 481 (defmethod intern-group (hsx a b)
 482   (ensuref (list 'group a b)
 483            (registratur hsx)
 484            (finalize-pattern (make-group a b))))
 485
 486 (defgeneric intern-interleave (handler a b))
 487 (defmethod intern-interleave (hsx (a pattern) (b not-allowed)) b)
 488 (defmethod intern-interleave (hsx (a not-allowed) (b pattern)) a)
 489 (defmethod intern-interleave (hsx a (b empty)) a)
 490 (defmethod intern-interleave (hsx (a empty) b) b)
 491 (defmethod intern-interleave (hsx a b)
 492   (ensuref (list 'interleave a b)
 493            (registratur hsx)
 494            (finalize-pattern (make-interleave a b))))
 495
 496 (defgeneric intern-after (handler a b))
 497 (defmethod intern-after (hsx (a pattern) (b not-allowed)) b)
 498 (defmethod intern-after (hsx (a not-allowed) (b pattern)) a)
 499 (defmethod intern-after (hsx a b)
 500   (ensuref (list 'after a b)
 501            (registratur hsx)
 502            (finalize-pattern (make-after a b))))
 503
 504 (defgeneric intern-one-or-more (handler c))
 505 (defmethod intern-one-or-more (hsx (c not-allowed)) c)
 506 (defmethod intern-one-or-more (hsx c)
 507   (ensuref (list 'one-or-more c)
 508            (registratur hsx)
 509            (finalize-pattern (make-one-or-more c))))
 510
 511
 512 ;;;; ENSURE-REGISTRATUR
 513
 514 (defvar *seen-elements*)
 515
 516 (defun ensure-registratur (grammar)
 517   (or (schema-registratur grammar)
 518       (setf (schema-registratur grammar)
 519             (let ((table (make-hash-table :test 'equal))
 520                   (*seen-elements* '())
 521                   (done-elements '()))
 522               (setf (schema-interned-start grammar)
 523                     (intern-pattern (schema-start grammar) table))
 524               (loop
 525                  for elements = *seen-elements*
 526                  while elements do
 527                    (setf *seen-elements* nil)
 528                    (dolist (pattern elements)
 529                      (unless (find pattern done-elements)
 530                        (push pattern done-elements)
 531                        (setf (pattern-child pattern)
 532                              (intern-pattern (pattern-child pattern) table)))))
 533               table))))
 534
 535 ;;; FIXME: misnamed.  we don't really intern the originals pattern yet.
 536
 537 (defgeneric intern-pattern (pattern table))
 538
 539 (defmethod intern-pattern ((pattern element) table)
 540   (let ((copy (ensuref (list 'element pattern)
 541                        table
 542                        (copy-structure pattern))))
 543     (pushnew copy *seen-elements*)
 544     copy))
 545
 546 (defmethod intern-pattern :around ((pattern pattern) table)
 547   (finalize-pattern (call-next-method)))
 548
 549 (defmethod intern-pattern ((pattern %parent) table)
 550   (let ((c (intern-pattern (pattern-child pattern) table)))
 551     (if (eq c (pattern-child pattern))
 552         pattern
 553         (let ((copy (copy-structure pattern)))
 554           (setf (pattern-child copy) c)
 555           copy))))
 556
 557 (defmethod intern-pattern ((pattern %combination) table)
 558   (let ((a (intern-pattern (pattern-a pattern) table))
 559         (b (intern-pattern (pattern-b pattern) table)))
 560     (if (and (eq a (pattern-a pattern)) (eq b (pattern-b pattern)))
 561         pattern
 562         (let ((copy (copy-structure pattern)))
 563           (setf (pattern-a copy) a)
 564           (setf (pattern-b copy) b)
 565           copy))))
 566
 567 (defmethod intern-pattern ((pattern data) table)
 568   (let ((e (when (pattern-except pattern)
 569              (intern-pattern (pattern-except pattern) table))))
 570     (if (eq e (pattern-except pattern))
 571         pattern
 572         (let ((copy (copy-structure pattern)))
 573           (setf (pattern-except copy) e)
 574           copy))))
 575
 576 (defmethod intern-pattern ((pattern ref) table)
 577   (intern-pattern (defn-child (pattern-target pattern)) table))
 578
 579 (defmethod intern-pattern ((pattern empty) table)
 580   *empty*)
 581
 582 (defmethod intern-pattern ((pattern not-allowed) table)
 583   *not-allowed*)
 584
 585 (defmethod intern-pattern ((pattern %leaf) table)
 586   pattern)
 587
 588
 589 ;;;; APPLY-AFTER
 590
 591 (defgeneric apply-after (handler fn pattern))
 592
 593 (defmethod apply-after (hsx fn (pattern after))
 594   (intern-after hsx
 595                 (pattern-a pattern)
 596                 (funcall fn (pattern-b pattern))))
 597
 598 (defmethod apply-after (hsx fn (pattern choice))
 599   (intern-choice hsx
 600                  (apply-after hsx fn (pattern-a pattern))
 601                  (apply-after hsx fn (pattern-b pattern))))
 602
 603 (defmethod apply-after (hsx fn (pattern not-allowed))
 604   (declare (ignore hsx fn))
 605   pattern)
 606
 607
 608 ;;;; OPEN-START-TAG'
 609
 610 (defgeneric open-start-tag\' (handler pattern uri lname))
 611
 612 (defmethod open-start-tag\' :around (hsx (pattern pattern) uri lname)
 613   (ensuref (list pattern uri lname)
 614            (open-start-tag\'-cache hsx)
 615            (call-next-method)))
 616
 617 (defmethod open-start-tag\' (hsx (pattern choice) uri lname)
 618   (intern-choice hsx
 619                  (open-start-tag\' hsx (pattern-a pattern) uri lname)
 620                  (open-start-tag\' hsx (pattern-b pattern) uri lname)))
 621
 622 (defmethod open-start-tag\' (hsx (pattern element) uri lname)
 623   (if (contains (pattern-name pattern) (or uri "") lname)
 624       (intern-after hsx (pattern-child pattern) *empty*)
 625       *not-allowed*))
 626
 627 (defmethod open-start-tag\' (hsx (pattern interleave) uri lname)
 628   (intern-choice hsx
 629                  (apply-after
 630                   hsx
 631                   (lambda (p) (intern-interleave hsx p (pattern-b pattern)))
 632                   (open-start-tag\' hsx (pattern-a pattern) uri lname))
 633                  (apply-after
 634                   hsx
 635                   (lambda (p) (intern-interleave hsx (pattern-a pattern) p))
 636                   (open-start-tag\' hsx (pattern-b pattern) uri lname))))
 637
 638 (defun intern-zero-or-more (hsx c)
 639   (intern-choice hsx (intern-one-or-more hsx c) *empty*))
 640
 641 (defmethod open-start-tag\' (hsx (pattern one-or-more) uri lname)
 642   (let ((c (intern-zero-or-more hsx (pattern-child pattern))))
 643     (apply-after hsx
 644                  (lambda (p) (intern-group hsx p c))
 645                  (open-start-tag\' hsx (pattern-child pattern) uri lname))))
 646
 647 (defmethod open-start-tag\' (hsx (pattern group) uri lname)
 648   (let ((x (apply-after hsx
 649                         (lambda (p)
 650                           (intern-group hsx p (pattern-b pattern)))
 651                         (open-start-tag\' hsx (pattern-a pattern) uri lname))))
 652     (if (nullable (pattern-a pattern))
 653         (intern-choice hsx
 654                        x
 655                        (open-start-tag\' hsx (pattern-b pattern) uri lname))
 656         x)))
 657
 658 (defmethod open-start-tag\' (hsx (pattern after) uri lname)
 659   (apply-after hsx
 660                (lambda (p)
 661                  (intern-after hsx p (pattern-b pattern)))
 662                (open-start-tag\' hsx (pattern-a pattern) uri lname)))
 663
 664 (defmethod open-start-tag\' (hsx pattern uri lname)
 665   (declare (ignore hsx pattern uri lname))
 666   *not-allowed*)
 667
 668
 669 ;;;; ATTRIBUTES'
 670
 671 (defun attributes\' (handler pattern attributes)
 672   (dolist (a attributes)
 673     (setf pattern (attribute\' handler pattern a))
 674     (advance handler pattern "attribute not valid: ~A" a))
 675   pattern)
 676
 677 (defgeneric attribute\' (handler pattern attribute))
 678
 679 (defmethod attribute\' (hsx (pattern after) a)
 680   (intern-after hsx
 681                 (attribute\' hsx (pattern-a pattern) a)
 682                 (pattern-b pattern)))
 683
 684 (defmethod attribute\' (hsx (pattern choice) a)
 685   (intern-choice hsx
 686                  (attribute\' hsx (pattern-a pattern) a)
 687                  (attribute\' hsx (pattern-b pattern) a)))
 688
 689 (defmethod attribute\' (hsx (pattern group) a)
 690   (intern-choice hsx
 691                  (intern-group hsx
 692                                (attribute\' hsx (pattern-a pattern) a)
 693                                (pattern-b pattern))
 694                  (intern-group hsx
 695                                (pattern-a pattern)
 696                                (attribute\' hsx (pattern-b pattern) a))))
 697
 698 (defmethod attribute\' (hsx (pattern interleave) a)
 699   (intern-choice hsx
 700                  (intern-interleave hsx
 701                                     (attribute\' hsx (pattern-a pattern) a)
 702                                     (pattern-b pattern))
 703                  (intern-interleave hsx
 704                                     (pattern-a pattern)
 705                                     (attribute\' hsx (pattern-b pattern) a))))
 706
 707 (defmethod attribute\' (hsx (pattern one-or-more) a)
 708   (intern-group hsx
 709                 (attribute\' hsx (pattern-child pattern) a)
 710                 (intern-zero-or-more hsx (pattern-child pattern))))
 711
 712 (defmethod attribute\' (hsx (pattern attribute) a)
 713   (eat (and (contains (pattern-name pattern)
 714                       (or (sax:attribute-namespace-uri a) "")
 715                       (sax:attribute-local-name a))
 716             (value-matches-p hsx
 717                              (pattern-child pattern)
 718                              (sax:attribute-value a)))))
 719
 720 (defun value-matches-p (hsx pattern value)
 721   (or (and (nullable pattern) (whitespacep value))
 722       (nullable (text-only\' hsx pattern value))))
 723
 724 (defun whitespacep (str)
 725   (zerop (length (string-trim *whitespace* str))))
 726
 727 (defmethod attribute\' (hsx pattern a)
 728   (declare (ignore hsx pattern a))
 729   *not-allowed*)
 730
 731
 732 ;;;; CLOSE-START-TAG'
 733
 734 (defgeneric close-start-tag\' (handler pattern))
 735
 736 (defmethod close-start-tag\' :around (hsx (pattern pattern))
 737   (ensuref pattern (close-start-tag\'-cache hsx) (call-next-method)))
 738
 739 (defmethod close-start-tag\' (hsx (pattern after))
 740   (intern-after hsx
 741                 (close-start-tag\' hsx (pattern-a pattern))
 742                 (pattern-b pattern)))
 743
 744 (defmethod close-start-tag\' (hsx (pattern choice))
 745   (intern-choice hsx
 746                 (close-start-tag\' hsx (pattern-a pattern))
 747                 (close-start-tag\' hsx (pattern-b pattern))))
 748
 749 (defmethod close-start-tag\' (hsx (pattern group))
 750   (intern-group hsx
 751                 (close-start-tag\' hsx (pattern-a pattern))
 752                 (close-start-tag\' hsx (pattern-b pattern))))
 753
 754 (defmethod close-start-tag\' (hsx (pattern interleave))
 755   (intern-interleave hsx
 756                      (close-start-tag\' hsx (pattern-a pattern))
 757                      (close-start-tag\' hsx (pattern-b pattern))))
 758
 759 (defmethod close-start-tag\' (hsx (pattern one-or-more))
 760   (intern-one-or-more hsx (close-start-tag\' hsx (pattern-child pattern))))
 761
 762 (defmethod close-start-tag\' (hsx (pattern attribute))
 763   (declare (ignore hsx))
 764   *not-allowed*)
 765
 766 (defmethod close-start-tag\' (hsx pattern)
 767   (declare (ignore hsx))
 768   pattern)
 769
 770
 771 ;;;; END-TAG\'
 772
 773 (defgeneric end-tag\' (handler pattern))
 774
 775 (defmethod end-tag\' :around (hsx (pattern pattern))
 776   (ensuref pattern (end-tag\'-cache hsx) (call-next-method)))
 777
 778 (defmethod end-tag\' (hsx (pattern choice))
 779   (intern-choice hsx
 780                  (end-tag\' hsx (pattern-a pattern))
 781                  (end-tag\' hsx (pattern-b pattern))))
 782
 783 (defmethod end-tag\' (hsx (pattern after))
 784   (if (nullable (pattern-a pattern))
 785       (pattern-b pattern)
 786       *not-allowed*))
 787
 788 (defmethod end-tag\' (hsx pattern)
 789   (declare (ignore hsx pattern))
 790   *not-allowed*)
 791
 792
 793 ;;;; TEXT NORMALIZER
 794
 795 ;;; FIXME: cxml should do that
 796
 797 ;;; FIXME: since we ignore PI, CDATA, and comment events, we should probably
 798 ;;; discard them properly.
 799
 800 (defclass text-normalizer (cxml:sax-proxy)
 801   ((pending-text-node :initform (make-string-output-stream)
 802                       :accessor pending-text-node)))
 803
 804 (defmethod sax:characters ((handler text-normalizer) data)
 805   (write-string data (pending-text-node handler)))
 806
 807 (defun flush-pending (handler)
 808   (let ((str (get-output-stream-string (pending-text-node handler))))
 809     (unless (zerop (length str))
 810       (sax:characters (cxml:proxy-chained-handler handler) str))))
 811
 812 (defmethod sax:start-element :before
 813     ((handler text-normalizer) uri lname qname attributes)
 814   (declare (ignore uri lname qname attributes))
 815   (flush-pending handler))
 816
 817 (defmethod sax:end-element :before
 818     ((handler text-normalizer) uri lname qname)
 819   (declare (ignore uri lname qname))
 820   (flush-pending handler))
 821
 822
 823 ;;;; EXPECTATION, DESCRIBE-NAME
 824
 825 (defgeneric expectation (pattern stream))
 826 (defgeneric describe-name (name-class stream))
 827
 828 (defmethod expectation ((pattern after) s)
 829   (expectation (pattern-a pattern) s))
 830
 831 (defmethod expectation ((pattern group) s)
 832   (cond
 833     ;; zzz: for better error messages with attributes we should probably
 834     ;; have a separate attribute-expectation function
 835     ((typep (pattern-a pattern) 'attribute)
 836      (pprint-logical-block (s nil)
 837        (expectation (pattern-a pattern) s)
 838        (when (typep (pattern-a pattern) 'attribute)
 839          (format s "~:@_and ")
 840          (expectation (pattern-b pattern) s))))
 841     (t
 842      (expectation (pattern-a pattern) s))))
 843
 844 (defmethod expectation ((pattern attribute) s)
 845   (pprint-logical-block (s nil)
 846     (write-string "an attribute " s)
 847     (describe-name (pattern-name pattern) s)
 848     (format s "~:@_with a value of ")
 849     (expectation (pattern-child pattern) s)))
 850
 851 (defmethod expectation ((pattern choice) s)
 852   (pprint-logical-block (s nil)
 853     (expectation (pattern-a pattern) s)
 854     (format s "~:@_or ")
 855     (expectation (pattern-b pattern) s)))
 856
 857 (defmethod expectation ((pattern element) s)
 858   (pprint-logical-block (s nil)
 859     (write-string "an element " s)
 860     (describe-name (pattern-name pattern) s)))
 861
 862 (defmethod expectation ((pattern data) s)
 863   (format s "a text node of type ~A" (pattern-type pattern)))
 864
 865 (defmethod expectation ((pattern interleave) s)
 866   (pprint-logical-block (s nil)
 867     (expectation (pattern-a pattern) s)
 868     (format s "~:@_interleaved with ")
 869     (expectation (pattern-b pattern) s)))
 870
 871 (defmethod expectation ((pattern list-pattern) s)
 872   (pprint-logical-block (s nil)
 873     (format s "a whitespace separated list of:~:@_")
 874     (expectation (pattern-child pattern) s)))
 875
 876 (defmethod expectation ((pattern not-allowed) s)
 877   (write-string "nothing" s))
 878
 879 (defmethod expectation ((pattern one-or-more) s)
 880   (pprint-logical-block (s nil)
 881     (format s "one or more of:~:@_")
 882     (expectation (pattern-child pattern) s)))
 883
 884 (defmethod expectation ((pattern text) s)
 885   (write-string "whitespace" s))
 886
 887 (defmethod expectation ((pattern value) s)
 888   (format s "a text node of type ~A and value ~S"
 889           (pattern-type pattern)
 890           (pattern-value pattern)))
 891
 892 (defmethod expectation ((pattern empty) s)
 893   (write-string "nothing more" s))
 894
 895 (defmethod describe-name ((nc name) s)
 896   (format s "named ~S, in the namespace ~S"
 897           (name-lname nc)
 898           (name-uri nc)))
 899
 900 (defmethod describe-name ((nc any-name) s)
 901   (pprint-logical-block (s nil)
 902     (write-string "of any name" s)
 903     (when (any-name-except nc)
 904       (format s "~:@_except ")
 905       (describe-name (any-name-except nc) s))))
 906
 907 (defmethod describe-name ((nc ns-name) s)
 908   (pprint-logical-block (s nil)
 909     (format s "with a name in the namespace ~S" (ns-name-uri nc))
 910     (when (ns-name-except nc)
 911       (format s "~:@_except for ")
 912       (describe-name (ns-name-except nc) s))))
 913
 914 (defmethod describe-name ((nc name-class-choice) s)
 915   (pprint-logical-block (s nil)
 916     (describe-name (name-class-choice-a nc) s)
 917     (format s "~:@_or ")
 918     (describe-name (name-class-choice-b nc) s)))
 919
 920
 921 ;;;; DTD-COMPATIBILITY-HANDLER
 922
 923 (defclass dtd-compatibility-handler
 924     (cxml:broadcast-handler cxml-types:sax-validation-context-mixin)
 925     ((compatibility-table :initarg :compatibility-table
 926                           :accessor compatibility-table)
 927      (extra-namespaces :initform nil :accessor extra-namespaces)
 928      (seen-ids :initform (make-hash-table :test 'equal) :accessor seen-ids)
 929      (seen-idrefs :initform nil :accessor seen-idrefs)))
 930
 931 (defmethod sax:start-element
 932     ((hsx dtd-compatibility-handler) uri lname qname attributes)
 933   (declare (ignore qname))
 934   (push nil (extra-namespaces hsx))
 935   (let ((dtd-element
 936          (gethash (list (or uri "") lname)
 937                   (dtd-elements
 938                    (compatibility-table hsx))))
 939         (*error-class* 'dtd-compatibility-error))
 940     (when dtd-element
 941       (loop for a being each hash-value in (dtd-attributes dtd-element) do
 942            (setf attributes (process-dtd-attribute hsx a attributes)))))
 943   (call-next-method hsx uri lname qname attributes))
 944
 945 (defmethod sax:end-element :before
 946     ((hsx dtd-compatibility-handler) uri lname qname)
 947   (declare (ignore uri lname qname))
 948   (dolist (c (pop (extra-namespaces hsx)))
 949     (dolist (next (cxml:broadcast-handler-handlers hsx))
 950       (sax:end-prefix-mapping next (car c)))))
 951
 952 (defmethod sax:end-document :before ((hsx dtd-compatibility-handler))
 953   (let ((*error-class* 'dtd-compatibility-error))
 954     (dolist (id (seen-idrefs hsx))
 955       (unless (gethash id (seen-ids hsx))
 956         (rng-error nil "referenced ID ~A not defined" id)))))
 957
 958 (defun process-dtd-attribute (hsx a attributes)
 959   (let* ((uri (name-uri (dtd-name a)))
 960          (lname (name-lname (dtd-name a)))
 961          (b (find-if (lambda (b)
 962                        (and (equal (or (sax:attribute-namespace-uri b) "") uri)
 963                             (equal (sax:attribute-local-name b) lname)))
 964                      attributes)))
 965     (cond
 966       (b
 967        (let ((ids (cl-ppcre:split #.(format nil "[~A]+" *whitespace*)
 968                                   (sax:attribute-value b))))
 969          (when ids
 970            (case (dtd-id-type a)
 971              ((nil))
 972              (:id
 973               (when (cdr ids)
 974                 (rng-error hsx "more than one token in ID: ~A" ids))
 975               (let ((id (car ids)))
 976                 (when (gethash id (seen-ids hsx))
 977                   (rng-error hsx "multiple declarations for ID: ~A" id))
 978                 (setf (gethash id (seen-ids hsx)) t)))
 979              ((:idref :idrefs)
 980               (setf (seen-idrefs hsx) (append ids (seen-idrefs hsx))))))))
 981       (t
 982        (when (dtd-default-value a)
 983          (let ((prefix
 984                 (flet ((uri-to-prefix (stack)
 985                          (car (find uri stack :key #'cdr :test #'equal))))
 986                   (or (uri-to-prefix (cxml-types::context-stack hsx))
 987                       (some #'uri-to-prefix (extra-namespaces hsx))))))
 988            (unless prefix
 989              (setf prefix
 990                    (loop
 991                       for i from 0
 992                       for name = (format nil "ns-~D" i)
 993                       while (find name
 994                                   (cxml-types::context-stack hsx)
 995                                   :key #'car
 996                                   :test #'equal)
 997                       finally (return name)))
 998              (when sax:*include-xmlns-attributes*
 999                (push (sax:make-attribute
1000                       :namespace-uri "http://www.w3.org/2000/xmlns/"
1001                       :local-name prefix
1002                       :qname (format nil "xmlns:~A" prefix)
1003                       :value uri
1004                       :specified-p nil)
1005                      attributes))
1006              (push (cons prefix uri) (car (extra-namespaces hsx)))
1007              (dolist (next (cxml:broadcast-handler-handlers hsx))
1008                (sax:start-prefix-mapping next prefix uri)))
1009            (push (sax:make-attribute :namespace-uri uri
1010                                      :local-name lname
1011                                      :qname (format nil "~A:~A" prefix lname)
1012                                      :value (dtd-default-value a)
1013                                      :specified-p nil)
1014                  attributes))))))
1015   attributes)
1016
1017
1018 ;;;;
1019
1020 (finalize-pattern *empty*)
1021 (finalize-pattern *not-allowed*)