xml/sax-handler.lisp

   1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SAX; readtable: runes; Encoding: utf-8; -*-
   2 ;;; ---------------------------------------------------------------------------
   3 ;;;     Title: A SAX2-like API for the xml parser
   4 ;;;   Created: 2003-06-30
   5 ;;;    Author: Henrik Motakef <hmot@henrik-motakef.de>
   6 ;;;    Author: David Lichteblau
   7 ;;;   License: BSD
   8 ;;; ---------------------------------------------------------------------------
   9 ;;;  (c) copyright 2003 by Henrik Motakef
  10 ;;;  (c) copyright 2004 knowledgeTools Int. GmbH
  11 ;;;  (c) copyright 2005-2007 David Lichteblau
  12
  13 ;;; Redistribution and use  in source and binary   forms, with or  without
  14 ;;; modification, are permitted provided that the following conditions are
  15 ;;; met:
  16 ;;;
  17 ;;; 1. Redistributions  of  source  code  must retain  the above copyright
  18 ;;;    notice, this list of conditions and the following disclaimer.
  19 ;;;
  20 ;;; 2. Redistributions in  binary form must reproduce  the above copyright
  21 ;;;    notice, this list of conditions and the following disclaimer in the
  22 ;;;    documentation and/or other materials provided with the distribution
  23 ;;;
  24 ;;; THIS  SOFTWARE   IS PROVIDED ``AS  IS''   AND ANY  EXPRESS  OR IMPLIED
  25 ;;; WARRANTIES, INCLUDING, BUT NOT LIMITED  TO, THE IMPLIED WARRANTIES  OF
  26 ;;; MERCHANTABILITY  AND FITNESS FOR A  PARTICULAR PURPOSE ARE DISCLAIMED.
  27 ;;; IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
  28 ;;; INDIRECT,  INCIDENTAL,  SPECIAL, EXEMPLARY,  OR CONSEQUENTIAL  DAMAGES
  29 ;;; (INCLUDING, BUT NOT LIMITED TO,   PROCUREMENT OF SUBSTITUTE GOODS   OR
  30 ;;; SERVICES;  LOSS OF  USE,  DATA, OR  PROFITS; OR BUSINESS INTERRUPTION)
  31 ;;; HOWEVER  CAUSED AND ON ANY THEORY  OF LIABILITY,  WHETHER IN CONTRACT,
  32 ;;; STRICT LIABILITY, OR  TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
  33 ;;; IN ANY WAY  OUT OF THE  USE OF THIS SOFTWARE,  EVEN IF ADVISED OF  THE
  34 ;;; POSSIBILITY OF SUCH DAMAGE.
  35
  36 ;;; TODO/ Open Questions:
  37
  38 ;; o Missing stuff from Java SAX2:
  39 ;;   * ignorable-whitespace
  40 ;;   * skipped-entity
  41 ;;   * The whole ErrorHandler class, this is better handled using
  42 ;;     conditions (but isn't yet)
  43
  44 (defpackage :sax
  45   (:use :common-lisp)
  46   (:export #:*namespace-processing*
  47            #:*include-xmlns-attributes*
  48            #:*use-xmlns-namespace*
  49
  50            #:abstract-handler
  51            #:content-handler
  52            #:default-handler
  53
  54            #:make-attribute
  55            #:find-attribute
  56            #:find-attribute-ns
  57            #:attribute-namespace-uri
  58            #:attribute-local-name
  59            #:attribute-qname
  60            #:attribute-value
  61            #:attribute-specified-p
  62
  63            #:start-document
  64            #:start-prefix-mapping
  65            #:start-element
  66            #:characters
  67            #:unescaped
  68            #:processing-instruction
  69            #:end-element
  70            #:end-prefix-mapping
  71            #:end-document
  72            #:comment
  73            #:start-cdata
  74            #:end-cdata
  75            #:start-dtd
  76            #:end-dtd
  77            #:start-internal-subset
  78            #:unparsed-internal-subset
  79            #:end-internal-subset
  80            #:unparsed-entity-declaration
  81            #:external-entity-declaration
  82            #:internal-entity-declaration
  83            #:notation-declaration
  84            #:element-declaration
  85            #:attribute-declaration
  86            #:entity-resolver
  87
  88            #:sax-parser
  89            #:sax-parser-mixin
  90            #:register-sax-parser
  91            #:line-number
  92            #:column-number
  93            #:system-id
  94            #:xml-base))
  95
  96 (in-package :sax)
  97
  98
  99 ;;;; SAX-PARSER interface
 100
 101 (defclass sax-parser () ())
 102
 103 (defclass sax-parser-mixin ()           ;deprecated
 104     ((sax-parser :initform nil :reader sax-parser)))
 105
 106 (defgeneric line-number (sax-parser)
 107   (:documentation
 108    "Return an approximation of the current line number, or NIL.")
 109   (:method ((handler sax-parser-mixin))
 110     (if (sax-parser handler)
 111         (line-number (sax-parser handler))
 112         nil)))
 113
 114 (defgeneric column-number (sax-parser)
 115   (:documentation
 116    "Return an approximation of the current column number, or NIL.")
 117   (:method ((handler sax-parser-mixin))
 118     (if (sax-parser handler)
 119         (column-number (sax-parser handler))
 120         nil)))
 121
 122 (defgeneric system-id (sax-parser)
 123   (:documentation
 124    "Return the URI of the document being parsed.  This is either the
 125     main document, or the entity's system ID while contents of a parsed
 126     general external entity are being processed.")
 127   (:method ((handler sax-parser-mixin))
 128     (if (sax-parser handler)
 129         (system-id (sax-parser handler))
 130         nil)))
 131
 132 (defgeneric xml-base (sax-parser)
 133   (:documentation
 134    "Return the [Base URI] of the current element.  This URI can differ from
 135    the value returned by SAX:SYSTEM-ID if xml:base attributes are present.")
 136   (:method ((handler sax-parser-mixin))
 137     (if (sax-parser handler)
 138         (xml-base (sax-parser handler))
 139         nil)))
 140
 141
 142 ;;;; Configuration variables
 143
 144 ;; The http://xml.org/sax/features/namespaces property
 145 (defvar *namespace-processing* t
 146   "If non-nil (the default), namespace processing is enabled.
 147
 148 See also `start-element' and `end-element' for a detailed description
 149 of the consequences of modifying this variable, and
 150 `*include-xmlns-attributes*' and `*use-xmlns-namespace*' for further
 151 related options.")
 152
 153 ;; The http://xml.org/sax/features/namespace-prefixes property.
 154 (defvar *include-xmlns-attributes* t
 155   "If non-nil, namespace declarations are reported as normal
 156 attributes.
 157
 158 This variable has no effect unless `*namespace-processing*' is
 159 non-nil.
 160
 161 See also `*use-xmlns-namespace*', and `start-element' for a detailed
 162 description of the consequences of setting this variable.")
 163
 164 (defvar *use-xmlns-namespace* t
 165   "If this variable is nil (the default), attributes with a name like
 166 'xmlns:x' are not considered to be in a namespace, following the
 167 'Namespaces in XML' specification.
 168
 169 If it is non-nil, such attributes are considered to be in a namespace
 170 with the URI 'http://www.w3.org/2000/xmlns/', following an
 171 incompatible change silently introduced in the errata to that spec,
 172 and adopted by some W3C standards.
 173
 174 For example, an attribute like xmlns:ex='http://example.com' would be
 175 reported like this:
 176
 177 *use-xmlns-namespace*: nil
 178 namespace-uri:         nil
 179 local-name:            nil
 180 qname:                 #\"xmlns:ex\"
 181
 182 *use-xmlns-namespace*: t
 183 namespace-uri:         #\"http://www.w3.org/2000/xmlns/\"
 184 local-name:            #\"ex\"
 185 qname:                 #\"xmlns:ex\"
 186
 187 Setting this variable has no effect unless both
 188 `*namespace-processing*' and `*include-xmlns-attributes*' are non-nil.")
 189
 190
 191 ;;;; ATTRIBUTE
 192
 193 (defstruct (standard-attribute (:constructor make-attribute))
 194   namespace-uri
 195   local-name
 196   qname
 197   value
 198   specified-p)
 199
 200 (defmethod (setf attribute-namespace-uri)
 201     (newval (attribute standard-attribute))
 202   (setf (standard-attribute-namespace-uri attribute) newval))
 203
 204 (defmethod (setf attribute-local-name)
 205     (newval (attribute standard-attribute))
 206   (setf (standard-attribute-local-name attribute) newval))
 207
 208 (defmethod (setf attribute-qname)
 209     (newval (attribute standard-attribute))
 210   (setf (standard-attribute-qname attribute) newval))
 211
 212 (defmethod (setf attribute-value)
 213     (newval (attribute standard-attribute))
 214   (setf (standard-attribute-value attribute) newval))
 215
 216 (defmethod (setf attribute-specified-p)
 217     (newval (attribute standard-attribute))
 218   (setf (standard-attribute-specified-p attribute) newval))
 219
 220 (defgeneric attribute-namespace-uri (attribute)
 221   (:method ((attribute standard-attribute))
 222     (standard-attribute-namespace-uri attribute))
 223   (:method ((attribute hax:standard-attribute))
 224     ""))
 225
 226 (defgeneric attribute-local-name (attribute)
 227   (:method ((attribute standard-attribute))
 228     (standard-attribute-local-name attribute))
 229   (:method ((attribute hax:standard-attribute))
 230     (runes:rod-downcase (hax:attribute-name attribute))))
 231
 232 (defgeneric attribute-qname (attribute)
 233   (:method ((attribute standard-attribute))
 234     (standard-attribute-qname attribute))
 235   (:method ((attribute hax:standard-attribute))
 236     (runes:rod-downcase (hax:attribute-name attribute))))
 237
 238 (defgeneric attribute-value (attribute)
 239   (:method ((attribute standard-attribute))
 240     (standard-attribute-value attribute))
 241   (:method ((attribute hax:standard-attribute))
 242     (hax:attribute-value attribute)))
 243
 244 (defgeneric attribute-specified-p (attribute)
 245   (:method ((attribute standard-attribute))
 246     (standard-attribute-specified-p attribute))
 247   (:method ((attribute hax:standard-attribute))
 248     (hax:attribute-specified-p attribute)))
 249
 250 (defmethod hax:attribute-name ((attribute standard-attribute))
 251   (attribute-local-name attribute))
 252
 253 (defmethod hax:attribute-value ((attribute standard-attribute))
 254   (attribute-value attribute))
 255
 256 (defmethod hax:attribute-specified-p ((attribute standard-attribute))
 257   (attribute-specified-p attribute))
 258
 259 (defun %rod= (x y)
 260   ;; allow rods *and* strings *and* null
 261   (cond
 262     ((zerop (length x)) (zerop (length y)))
 263     ((zerop (length y)) nil)
 264     ((stringp x) (string= x y))
 265     (t (runes:rod= x y))))
 266
 267 (defun find-attribute (qname attrs)
 268   (find qname attrs :key #'attribute-qname :test #'%rod=))
 269
 270 (defun find-attribute-ns (uri lname attrs)
 271   (find-if (lambda (attr)
 272              (and (%rod= uri (sax:attribute-namespace-uri attr))
 273                   (%rod= lname (sax:attribute-local-name attr))))
 274            attrs))
 275
 276
 277 ;;;; ABSTRACT-HANDLER and DEFAULT-HANDLER
 278
 279 (defclass abstract-handler (sax-parser-mixin) ())
 280 (defclass content-handler (abstract-handler) ())
 281 (defclass default-handler (content-handler) ())
 282
 283
 284 ;;;; EVENTS
 285
 286 (macrolet ((define-event ((name default-handler-class)
 287                           (&rest args)
 288                           &body hax-body)
 289              `(defgeneric ,name (handler ,@args)
 290                 (:method ((handler null) ,@args)
 291                   (declare (ignore ,@args))
 292                   nil)
 293                 (:method ((handler t) ,@args)
 294                   (declare (ignore ,@args))
 295                   (warn "deprecated SAX default method used by a handler ~
 296                          that is not a subclass of SAX:ABSTRACT-HANDLER ~
 297                          or HAX:ABSTRACT-HANDLER")
 298                   nil)
 299                 (:method ((handler abstract-handler) ,@args)
 300                   (declare (ignore ,@args))
 301                   (error "SAX event ~A not implemented by this handler"
 302                          ',name))
 303                 (:method ((handler ,default-handler-class) ,@args)
 304                   (declare (ignore ,@args))
 305                   nil)
 306                 (:method ((handler hax:abstract-handler) ,@args)
 307                   (declare (ignorable ,@args))
 308                   ,@hax-body))))
 309   (define-event (start-document default-handler)
 310       ()
 311     nil)
 312
 313   (define-event (start-element default-handler)
 314       (namespace-uri local-name qname attributes)
 315     (setf attributes
 316           (remove "http://www.w3.org/2000/xmlns/"
 317                   attributes
 318                   :key #'attribute-namespace-uri
 319                   :test #'equal))
 320     (hax:start-element handler local-name attributes))
 321
 322   (define-event (start-prefix-mapping content-handler)
 323       (prefix uri)
 324     nil)
 325
 326   (define-event (characters default-handler)
 327       (data)
 328     (hax:characters handler data))
 329
 330   (define-event (unescaped default-handler)
 331       (data)
 332     (hax:unescaped handler data))
 333
 334   (define-event (processing-instruction default-handler)
 335       (target data)
 336     nil)
 337
 338   (define-event (end-prefix-mapping content-handler)
 339       (prefix)
 340     nil)
 341
 342   (define-event (end-element default-handler)
 343       (namespace-uri local-name qname)
 344     (hax:end-element handler local-name))
 345
 346   (define-event (end-document default-handler)
 347       ()
 348     (hax:end-document handler))
 349
 350   (define-event (comment content-handler)
 351       (data)
 352     (hax:comment handler data))
 353
 354   (define-event (start-cdata content-handler)
 355       ()
 356     nil)
 357
 358   (define-event (end-cdata content-handler)
 359       ()
 360     nil)
 361
 362   (define-event (start-dtd content-handler)
 363       (name public-id system-id)
 364     (hax:start-document handler name public-id system-id))
 365
 366   (define-event (end-dtd content-handler)
 367       ()
 368     nil)
 369
 370   (define-event (start-internal-subset content-handler)
 371       ()
 372     nil)
 373
 374   (define-event (end-internal-subset content-handler)
 375       ()
 376     nil)
 377
 378   (define-event (unparsed-internal-subset content-handler)
 379       (str)
 380     nil)
 381
 382   (define-event (unparsed-entity-declaration content-handler)
 383       (name public-id system-id notation-name)
 384     nil)
 385
 386   (define-event (external-entity-declaration content-handler)
 387       (kind name public-id system-id)
 388     nil)
 389
 390   (define-event (internal-entity-declaration content-handler)
 391       (kind name value)
 392     nil)
 393
 394   (define-event (notation-declaration content-handler)
 395       (name public-id system-id)
 396     nil)
 397
 398   (define-event (element-declaration content-handler)
 399       (name model)
 400     nil)
 401
 402   (define-event (attribute-declaration content-handler)
 403       (element-name attribute-name type default)
 404     nil)
 405
 406   (define-event (entity-resolver content-handler)
 407       (resolver)
 408     nil)
 409
 410   (define-event (dtd content-handler)
 411       (dtd)
 412     nil))
 413
 414 ;;; special case: this method is defined on abstract-handler through
 415 ;;; sax-parser-mixin
 416 (defgeneric register-sax-parser (handler sax-parser)
 417   (:method ((handler null) sax-parser)
 418     (declare (ignore sax-parser))
 419     nil)
 420   (:method ((handler sax-parser-mixin) sax-parser)
 421     (setf (slot-value handler 'sax-parser) sax-parser))
 422   (:method ((handler t) sax-parser)
 423     (declare (ignore sax-parser))
 424     (warn "deprecated sax default method used by a handler ~
 425                           that is not a subclass of sax:abstract-handler ~
 426                           or hax:abstract-handler")
 427     nil)
 428   (:method ((handler hax:abstract-handler) sax-parser)
 429     (declare (ignorable sax-parser)) nil))
 430
 431
 432 ;;;; HAX to SAX
 433
 434 (defmethod hax:start-document ((handler abstract-handler) name pubid sysid)
 435   (sax:start-document handler)
 436   (when sysid
 437     (sax:start-dtd handler name pubid sysid)
 438     (sax:end-dtd handler)))
 439
 440 (defmethod hax:start-element ((handler abstract-handler) name attributes)
 441   (setf name (runes:rod-downcase name))
 442   (when (equal name "html")
 443     (sax:start-prefix-mapping handler "" "http://www.w3.org/1999/xhtml")
 444     (when *include-xmlns-attributes*
 445       (push (make-attribute :namespace-uri "http://www.w3.org/2000/xmlns/"
 446                             :local-name nil
 447                             :qname "xmlns"
 448                             :value "http://www.w3.org/1999/xhtml"
 449                             :specified-p t)
 450             attributes)))
 451   (sax:start-element handler
 452                      "http://www.w3.org/1999/xhtml"
 453                      name
 454                      name
 455                      attributes))
 456
 457 (defmethod hax:end-element ((handler abstract-handler) name)
 458   (setf name (runes:rod-downcase name))
 459   (sax:end-element handler
 460                    "http://www.w3.org/1999/xhtml"
 461                    name
 462                    name)
 463   (when (equal name "html")
 464     (sax:end-prefix-mapping handler "")))
 465
 466 (defmethod hax:characters ((handler abstract-handler) data)
 467   (sax:characters handler data))
 468
 469 (defmethod hax:unescaped ((handler abstract-handler) data)
 470   (sax:unescaped handler data))
 471
 472 (defmethod hax:comment ((handler abstract-handler) str)
 473   (sax:comment handler str))
 474
 475 (defmethod hax:end-document ((handler abstract-handler))
 476   (sax:end-document handler))
 477
 478
 479
 480 ;;;; Documentation
 481
 482 (setf (documentation 'start-document 'function)
 483       "Called at the beginning of the parsing process,
 484 before any element, processing instruction or comment is reported.
 485
 486 Handlers that need to maintain internal state may use this to perform
 487 any neccessary initializations.")
 488
 489 (setf (documentation 'start-element 'function)
 490       "Called to report the beginning of an element.
 491
 492 There will always be a corresponding call to end-element, even in the
 493 case of an empty element (i.e. <foo/>).
 494
 495 If the value of *namespaces* is non-nil, namespace-uri, local-name and
 496 qname are rods. If it is nil, namespace-uri and local-name are always
 497 nil, and it is not an error if the qname is not a well-formed
 498 qualified element name (for example, if it contains more than one
 499 colon).
 500
 501 The attributes parameter is a list (in arbitrary order) of instances
 502 of the `attribute' structure class. The for their namespace-uri and
 503 local-name properties, the same rules as for the element name
 504 apply. Additionally, namespace-declaring attributes (those whose name
 505 is \"xmlns\" or starts with \"xmlns:\") are only included if
 506 *include-xmlns-attributes* is non-nil.")
 507
 508 (setf (documentation 'start-prefix-mapping 'function)
 509       "Called when the scope of a new prefix -> namespace-uri mapping begins.
 510
 511 This will always be called immediatly before the `start-element' event
 512 for the element on which the namespaces are declared.
 513
 514 Clients don't usually have to implement this except under special
 515 circumstances, for example when they have to deal with qualified names
 516 in textual content. The parser will handle namespaces of elements and
 517 attributes on its own.")
 518
 519 (setf (documentation 'characters 'function)
 520       "Called for textual element content.
 521
 522 The data is passed as a rod, with all entity references resolved.
 523 It is possible that the character content of an element is reported
 524 via multiple subsequent calls to this generic function.")
 525
 526 (setf (documentation 'unescaped 'function)
 527       "Called for unescaped element content.  Beware dragons.")
 528
 529 (setf (documentation 'processing-instruction 'function)
 530       "Called when a processing instruction is read.
 531
 532 Both target and data are rods.")
 533
 534 (setf (documentation 'end-prefix-mapping 'function)
 535       "Called when a prefix -> namespace-uri mapping goes out of scope.
 536
 537 This will always be called immediatly after the `end-element' event
 538 for the element on which the namespace is declared. The order of the
 539 end-prefix-mapping events is otherwise not guaranteed.
 540
 541 Clients don't usually have to implement this except under special
 542 circumstances, for example when they have to deal with qualified names
 543 in textual content. The parser will handle namespaces of elements and
 544 attributes on its own.")
 545
 546 (setf (documentation 'end-element 'function)
 547       "Called to report the end of an element.
 548
 549 See the documentation for `start-element' for a description of the
 550 parameters.")
 551
 552 (setf (documentation 'end-document 'function)
 553       "Called at the end of parsing a document.
 554 This is always the last function called in the parsing process.
 555
 556 In contrast to all of the other methods, the return value of this gf
 557 is significant, it will be returned by the parse-file/stream/string function.")
 558
 559 (setf (documentation 'start-cdata 'function)
 560       "Called at the beginning of parsing a CDATA section.
 561
 562 Handlers only have to implement this if they are interested in the
 563 lexical structure of the parsed document. The content of the CDATA
 564 section is reported via the `characters' generic function like all
 565 other textual content.")
 566
 567 (setf (documentation 'end-cdata 'function)
 568       "Called at the end of parsing a CDATA section.
 569
 570 Handlers only have to implement this if they are interested in the
 571 lexical structure of the parsed document. The content of the CDATA
 572 section is reported via the `characters' generic function like all
 573 other textual content.")
 574
 575 (setf (documentation 'start-dtd 'function)
 576       "Called at the beginning of parsing a DTD.")
 577
 578 (setf (documentation 'end-dtd 'function)
 579       "Called at the end of parsing a DTD.")
 580
 581 (setf (documentation 'start-internal-subset 'function)
 582       "Reports that an internal subset is present.  Called before
 583 any definition from the internal subset is reported.")
 584
 585 (setf (documentation 'end-internal-subset 'function)
 586       "Called after processing of the internal subset has
 587 finished, if present.")
 588
 589 (setf (documentation 'unparsed-internal-subset 'function)
 590       "Reports that an internal subset is present, but has not
 591 been parsed and is available as a string.")
 592
 593 (setf (documentation 'unparsed-entity-declaration 'function)
 594       "Called when an unparsed entity declaration is seen in a DTD.")
 595
 596 (setf (documentation 'external-entity-declaration 'function)
 597       "Called when a parsed external entity declaration is seen in a DTD.")
 598
 599 (setf (documentation 'internal-entity-declaration 'function)
 600       "Called when an internal entity declaration is seen in a DTD.")
 601
 602 (setf (documentation 'notation-declaration 'function)
 603       "Called when a notation declaration is seen while parsing a DTD.")
 604
 605 (setf (documentation 'element-declaration 'function)
 606       "Called when a element declaration is seen in a DTD.  Model is not a string,
 607     but a nested list, with *, ?, +, OR, and AND being the operators, rods
 608     as names, :EMPTY and :PCDATA as special tokens.  (AND represents
 609     sequences.)")
 610
 611 (setf (documentation 'attribute-declaration 'function)
 612       "Called when an attribute declaration is seen in a DTD.
 613     type        one of :CDATA, :ID, :IDREF, :IDREFS,
 614                 :ENTITY, :ENTITIES, :NMTOKEN, :NMTOKENS,
 615                 (:NOTATION <name>*), or (:ENUMERATION <name>*)
 616     default     :REQUIRED, :IMPLIED, (:FIXED content), or (:DEFAULT content)")
 617
 618 (setf (documentation 'entity-resolver 'function)
 619       "Called between sax:end-dtd and sax:end-document to register an entity
 620     resolver, a function of two arguments: An entity name and SAX handler.
 621     When called, the resolver function will parse the named entity's data.")
 622
 623 (setf (documentation 'register-sax-parser 'function)
 624       "Set the SAX-PARSER instance of this handler.")