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:consume-characters (source)
  83   (with-output-to-string (s)
  84     (while (eq (klacks:peek source) :characters)
  85       (write-string (klacks:current-characters source) s)
  86       (klacks:consume source))))
  87
  88 (defun klacks:serialize-event (source handler &key (consume t))
  89   (multiple-value-bind (key a b c) (klacks:peek source)
  90     (let ((result nil))
  91       (case key
  92         (:start-document
  93           (sax:start-document handler)
  94           (loop for (prefix . uri) in *initial-namespace-bindings* do
  95                (sax:start-prefix-mapping handler prefix uri)))
  96         (:characters
  97           (cond
  98             ((klacks:current-cdata-section-p source)
  99               (sax:start-cdata handler)
 100               (sax:characters handler a)
 101               (sax:end-cdata handler))
 102             (T
 103               (sax:characters handler a))))
 104         (:processing-instruction
 105           (sax:processing-instruction handler a b))
 106         (:comment
 107           (sax:comment handler a))
 108         (:dtd
 109           (sax:start-dtd handler a b c)
 110           (when (slot-boundp source 'internal-declarations)
 111             (sax:start-internal-subset handler)
 112             (serialize-declaration-kludge
 113              (slot-value source 'internal-declarations)
 114              handler)
 115             (sax:end-internal-subset handler))
 116           (serialize-declaration-kludge
 117            (slot-value source 'external-declarations)
 118            handler)
 119           (sax:end-dtd handler)
 120           (sax:entity-resolver handler
 121                                (slot-value source 'dom-impl-entity-resolver))
 122           (sax::dtd handler (slot-value source 'dom-impl-dtd)))
 123         (:start-element
 124           (klacks:map-current-namespace-declarations
 125            (lambda (prefix uri)
 126              (sax:start-prefix-mapping handler prefix uri))
 127            source)
 128           (sax:start-element handler a b c (klacks:list-attributes source)))
 129         (:end-element
 130           (sax:end-element handler a b c)
 131           (klacks:map-current-namespace-declarations
 132            (lambda (prefix uri)
 133              (declare (ignore uri))
 134              (sax:end-prefix-mapping handler prefix))
 135            source))
 136         (:end-document
 137          (loop for (prefix . nil) in *initial-namespace-bindings* do
 138               (sax:end-prefix-mapping handler prefix))
 139           (setf result (sax:end-document handler)))
 140         ((nil)
 141           (error "serialize-event read past end of document"))
 142         (t
 143           (error "unexpected klacks key: ~A" key)))
 144       (when consume
 145         (klacks:consume source))
 146       result)))
 147
 148 (defun serialize-declaration-kludge (list handler)
 149   (loop
 150       for (fn . args) in list
 151       do (apply fn handler args)))
 152
 153 (defun klacks:serialize-source (source handler)
 154   (loop
 155     (let ((document (klacks:serialize-event source handler)))
 156       (when document
 157         (return document)))))
 158
 159 (defclass klacksax (sax:sax-parser)
 160     ((source :initarg :source)))
 161
 162 (defmethod sax:line-number ((parser klacksax))
 163   (klacks:current-line-number (slot-value parser 'source)))
 164
 165 (defmethod sax:column-number ((parser klacksax))
 166   (klacks:current-column-number (slot-value parser 'source)))
 167
 168 (defmethod sax:system-id ((parser klacksax))
 169   (klacks:current-system-id (slot-value parser 'source)))
 170
 171 (defmethod sax:xml-base ((parser klacksax))
 172   (klacks:current-xml-base (slot-value parser 'source)))
 173
 174 (defun klacks:serialize-element (source handler &key (document-events t))
 175   (unless (eq (klacks:peek source) :start-element)
 176     (error "not at start of element"))
 177   (sax:register-sax-parser handler (make-instance 'klacksax :source source))
 178   (when document-events
 179     (sax:start-document handler))
 180   (labels ((recurse ()
 181              (klacks:serialize-event source handler)
 182              (loop
 183                (let ((key (klacks:peek source)))
 184                  (ecase key
 185                    (:start-element (recurse))
 186                    (:end-element (return))
 187                    ((:characters :comment :processing-instruction)
 188                      (klacks:serialize-event source handler)))))
 189              (klacks:serialize-event source handler)))
 190     (recurse))
 191   (when document-events
 192     (sax:end-document handler)))
 193
 194 (defun klacks:find-element (source &optional lname uri)
 195   (loop
 196     (multiple-value-bind (key current-uri current-lname current-qname)
 197         (klacks:peek source)
 198       (case key
 199         ((nil)
 200           (return nil))
 201         (:start-element
 202           (when (and (eq key :start-element)
 203                      (or (null lname)
 204                          (equal lname (klacks:current-lname source)))
 205                      (or (null uri)
 206                          (equal uri (klacks:current-uri source))))
 207             (return
 208               (values key current-uri current-lname current-qname)))))
 209       (klacks:consume source))))
 210
 211 (defun klacks:find-event (source key)
 212   (loop
 213     (multiple-value-bind (this a b c)
 214         (klacks:peek source)
 215       (cond
 216         ((null this)
 217           (return nil))
 218         ((eq this key)
 219           (return (values this a b c))))
 220       (klacks:consume source))))
 221
 222 (define-condition klacks:klacks-error (xml-parse-error) ())
 223
 224 (defun klacks-error (fmt &rest args)
 225   (%error 'klacks:klacks-error
 226           nil
 227           (format nil "Klacks assertion failed: ~?" fmt args)))
 228
 229 (defun klacks:expect (source key &optional u v w)
 230   (multiple-value-bind (this a b c)
 231       (klacks:peek source)
 232     (unless (eq this key) (klacks-error "expected ~A but got ~A" key this))
 233     (when (and u (not (equal a u)))
 234       (klacks-error "expected ~A but got ~A" u a))
 235     (when (and v (not (equal b v)))
 236       (klacks-error "expected ~A but got ~A" v b))
 237     (when (and w (not (equal c w)))
 238       (klacks-error "expected ~A but got ~A" w c))
 239     (values this a b c)))
 240
 241 (defun klacks:skip (source key &optional a b c)
 242   (klacks:expect source key a b c)
 243   (klacks:consume source))
 244
 245 (defun invoke-expecting-element (fn source &optional lname uri)
 246   (multiple-value-bind (key a b)
 247       (klacks:peek source)
 248     (unless (eq key :start-element)
 249       (klacks-error "expected ~A but got ~A" (or lname "element") key))
 250     (when (and uri (not (equal a uri)))
 251       (klacks-error "expected ~A but got ~A" uri a))
 252     (when (and lname (not (equal b lname)))
 253       (klacks-error "expected ~A but got ~A" lname b))
 254     (multiple-value-prog1
 255         (funcall fn)
 256       (klacks:skip source :end-element a b))))
 257
 258 (defmacro klacks:expecting-element ((source &optional lname uri) &body body)
 259   `(invoke-expecting-element (lambda () ,@body) ,source ,lname ,uri))