klacks/klacks.lisp

   1 ;;; -*- Mode: Lisp; readtable: runes; -*-
   2 ;;;  (c) copyright 2007 David Lichteblau
   3
   4 ;;; This library is free software; you can redistribute it and/or
   5 ;;; modify it under the terms of the GNU Library General Public
   6 ;;; License as published by the Free Software Foundation; either
   7 ;;; version 2 of the License, or (at your option) any later version.
   8 ;;;
   9 ;;; This library is distributed in the hope that it will be useful,
  10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;;; Library General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU Library General Public
  15 ;;; License along with this library; if not, write to the
  16 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  17 ;;; Boston, MA  02111-1307  USA.
  18
  19 (in-package :cxml)
  20
  21 (defclass klacks:source ()
  22     (
  23      ;; fixme, terrible DTD kludges
  24      (internal-declarations)
  25      (external-declarations :initform nil)
  26      (dom-impl-dtd :initform nil)
  27      (dom-impl-entity-resolver :initform nil)))
  28
  29 (defgeneric klacks:close-source (source))
  30
  31 (defgeneric klacks:peek (source))
  32 (defgeneric klacks:peek-value (source))
  33 (defgeneric klacks:consume (source))
  34
  35 (defgeneric klacks:map-attributes (fn source))
  36 (defgeneric klacks:list-attributes (source))
  37 (defgeneric klacks:get-attribute (source lname &optional uri))
  38 ;;;(defgeneric klacks:current-uri (source))
  39 ;;;(defgeneric klacks:current-lname (source))
  40 ;;;(defgeneric klacks:current-qname (source))
  41 ;;;(defgeneric klacks:current-characters (source))
  42 (defgeneric klacks:current-cdata-section-p (source))
  43 (defgeneric klacks:map-current-namespace-declarations (fn source))
  44
  45 (defgeneric klacks:current-line-number (source))
  46 (defgeneric klacks:current-column-number (source))
  47 (defgeneric klacks:current-system-id (source))
  48 (defgeneric klacks:current-xml-base (source))
  49
  50 (defgeneric klacks:find-namespace-binding (prefix source))
  51 (defgeneric klacks:decode-qname (qname source))
  52
  53 (defmacro klacks:with-open-source ((var source) &body body)
  54   `(let ((,var ,source))
  55      (unwind-protect
  56          (progn ,@body)
  57        (klacks:close-source ,var))))
  58
  59 (defun klacks:current-uri (source)
  60   (multiple-value-bind (key uri lname qname) (klacks:peek source)
  61     (declare (ignore lname qname))
  62     (check-type key (member :start-element :end-element))
  63     uri))
  64
  65 (defun klacks:current-lname (source)
  66   (multiple-value-bind (key uri lname qname) (klacks:peek source)
  67     (declare (ignore uri qname))
  68     (check-type key (member :start-element :end-element))
  69     lname))
  70
  71 (defun klacks:current-qname (source)
  72   (multiple-value-bind (key uri lname qname) (klacks:peek source)
  73     (declare (ignore uri lname))
  74     (check-type key (member :start-element :end-element))
  75     qname))
  76
  77 (defun klacks:current-characters (source)
  78   (multiple-value-bind (key characters) (klacks:peek source)
  79     (check-type key (member :characters))
  80     characters))
  81
  82 (defun klacks:serialize-event (source handler &key (consume t))
  83   (multiple-value-bind (key a b c) (klacks:peek source)
  84     (let ((result nil))
  85       (case key
  86         (:start-document
  87           (sax:start-document handler)
  88           (loop for (prefix . uri) in *initial-namespace-bindings* do
  89                (sax:start-prefix-mapping handler prefix uri)))
  90         (:characters
  91           (cond
  92             ((klacks:current-cdata-section-p source)
  93               (sax:start-cdata source)
  94               (sax:characters handler a)
  95               (sax:end-cdata source))
  96             (T
  97               (sax:characters handler a))))
  98         (:processing-instruction
  99           (sax:processing-instruction handler a b))
 100         (:comment
 101           (sax:comment handler a))
 102         (:dtd
 103           (sax:start-dtd handler a b c)
 104           (when (slot-boundp source 'internal-declarations)
 105             (sax:start-internal-subset handler)
 106             (serialize-declaration-kludge
 107              (slot-value source 'internal-declarations)
 108              handler)
 109             (sax:end-internal-subset handler))
 110           (serialize-declaration-kludge
 111            (slot-value source 'external-declarations)
 112            handler)
 113           (sax:end-dtd handler)
 114           (sax:entity-resolver handler
 115                                (slot-value source 'dom-impl-entity-resolver))
 116           (sax::dtd handler (slot-value source 'dom-impl-dtd)))
 117         (:start-element
 118           (klacks:map-current-namespace-declarations
 119            (lambda (prefix uri)
 120              (sax:start-prefix-mapping handler prefix uri))
 121            source)
 122           (sax:start-element handler a b c (klacks:list-attributes source)))
 123         (:end-element
 124           (sax:end-element handler a b c)
 125           (klacks:map-current-namespace-declarations
 126            (lambda (prefix uri)
 127              (declare (ignore uri))
 128              (sax:end-prefix-mapping handler prefix))
 129            source))
 130         (:end-document
 131          (loop for (prefix . nil) in *initial-namespace-bindings* do
 132               (sax:end-prefix-mapping handler prefix))
 133           (setf result (sax:end-document handler)))
 134         ((nil)
 135           (error "serialize-event read past end of document"))
 136         (t
 137           (error "unexpected klacks key: ~A" key)))
 138       (when consume
 139         (klacks:consume source))
 140       result)))
 141
 142 (defun serialize-declaration-kludge (list handler)
 143   (loop
 144       for (fn . args) in list
 145       do (apply fn handler args)))
 146
 147 (defun klacks:serialize-source (source handler)
 148   (loop
 149     (let ((document (klacks:serialize-event source handler)))
 150       (when document
 151         (return document)))))
 152
 153 (defclass klacksax (sax:sax-parser)
 154     ((source :initarg :source)))
 155
 156 (defmethod sax:line-number ((parser klacksax))
 157   (klacks:current-line-number (slot-value parser 'source)))
 158
 159 (defmethod sax:column-number ((parser klacksax))
 160   (klacks:current-column-number (slot-value parser 'source)))
 161
 162 (defmethod sax:system-id ((parser klacksax))
 163   (klacks:current-system-id (slot-value parser 'source)))
 164
 165 (defmethod sax:xml-base ((parser klacksax))
 166   (klacks:current-xml-base (slot-value parser 'source)))
 167
 168 (defun klacks:serialize-element (source handler &key (document-events t))
 169   (unless (eq (klacks:peek source) :start-element)
 170     (error "not at start of element"))
 171   (sax:register-sax-parser handler (make-instance 'klacksax :source source))
 172   (when document-events
 173     (sax:start-document handler))
 174   (labels ((recurse ()
 175              (klacks:serialize-event source handler)
 176              (loop
 177                (let ((key (klacks:peek source)))
 178                  (ecase key
 179                    (:start-element (recurse))
 180                    (:end-element (return))
 181                    ((:characters :comment :processing-instruction)
 182                      (klacks:serialize-event source handler)))))
 183              (klacks:serialize-event source handler)))
 184     (recurse))
 185   (when document-events
 186     (sax:end-document handler)))
 187
 188 (defun klacks:find-element (source &optional lname uri)
 189   (loop
 190     (multiple-value-bind (key current-uri current-lname current-qname)
 191         (klacks:peek source)
 192       (case key
 193         ((nil)
 194           (return nil))
 195         (:start-element
 196           (when (and (eq key :start-element)
 197                      (or (null lname)
 198                          (equal lname (klacks:current-lname source)))
 199                      (or (null uri)
 200                          (equal uri (klacks:current-uri source))))
 201             (return
 202               (values key current-uri current-lname current-qname)))))
 203       (klacks:consume source))))
 204
 205 (defun klacks:find-event (source key)
 206   (loop
 207     (multiple-value-bind (this a b c)
 208         (klacks:peek source)
 209       (cond
 210         ((null this)
 211           (return nil))
 212         ((eq this key)
 213           (return (values this a b c))))
 214       (klacks:consume source))))
 215
 216 (define-condition klacks-error (xml-parse-error) ())
 217
 218 (defun klacks-error (fmt &rest args)
 219   (%error 'klacks-error
 220           nil
 221           (format nil "Klacks assertion failed: ~?" fmt args)))
 222
 223 (defun klacks:expect (source key &optional u v w)
 224   (multiple-value-bind (this a b c)
 225       (klacks:peek source)
 226     (unless (eq this key) (klacks-error "expected ~A but got ~A" key this))
 227     (when (and u (not (equal a u)))
 228       (klacks-error "expected ~A but got ~A" u a))
 229     (when (and v (not (equal b v)))
 230       (klacks-error "expected ~A but got ~A" v b))
 231     (when (and w (not (equal c w)))
 232       (klacks-error "expected ~A but got ~A" w c))
 233     (values this a b c)))
 234
 235 (defun klacks:skip (source key &optional a b c)
 236   (klacks:expect source key a b c)
 237   (klacks:consume source))
 238
 239 (defun invoke-expecting-element (fn source &optional lname uri)
 240   (multiple-value-bind (key a b)
 241       (klacks:peek source)
 242     (unless (eq key :start-element)
 243       (klacks-error "expected ~A but got ~A" (or lname "element") key))
 244     (when (and uri (not (equal a uri)))
 245       (klacks-error "expected ~A but got ~A" uri a))
 246     (when (and lname (not (equal b lname)))
 247       (klacks-error "expected ~A but got ~A" lname b))
 248     (multiple-value-prog1
 249         (funcall fn)
 250       (klacks:skip source :end-element a b))))
 251
 252 (defmacro klacks:expecting-element ((source &optional lname uri) &body body)
 253   `(invoke-expecting-element (lambda () ,@body) ,source ,lname ,uri))