Update of /project/cxml/cvsroot/cxml/klacks
In directory clnet:/tmp/cvs-serv17056/klacks
Modified Files:
klacks-impl.lisp klacks.lisp package.lisp
Added Files:
tap-source.lisp
Log Message:
+ <li>New class <tt>broadcast-handler</tt> as a generalization
+ of the older <tt>sax-proxy</tt>.</li>
+ <li>New class <tt>tapping-source</tt>, a klacks source that
+ relays events from an upstream klacks source unchanged, while also
+ emitting them as SAX events to a user-specified handler at the
+ same time.</li>
+ Fixed serialize-event to generate
+ start-prefix-mapping and end-prefix-mapping events. New function
+ map-current-namespace-declarations.</li>
--- /project/cxml/cvsroot/cxml/klacks/klacks-impl.lisp 2007/03/04 21:41:07 1.7
+++ /project/cxml/cvsroot/cxml/klacks/klacks-impl.lisp 2007/04/22 13:23:55 1.8
@@ -34,6 +34,7 @@
;; extra WITH-SOURCE magic
(data-behaviour :initform :DTD)
(namespace-stack :initform (list *initial-namespace-bindings*))
+ (current-namespace-declarations)
(temporary-streams :initform nil)
(scratch-pad :initarg :scratch-pad)
(scratch-pad-2 :initarg :scratch-pad-2)
@@ -281,12 +282,13 @@
#'klacks/done)))
(defun klacks/element (source input cont)
- (with-source (source current-key current-values current-attributes)
+ (with-source (source current-key current-values current-attributes
+ current-namespace-declarations)
(multiple-value-bind (cat n-b new-b uri lname qname attrs) (p/sztag input)
- (declare (ignore new-b))
(setf current-key :start-element)
(setf current-values (list uri lname qname))
(setf current-attributes attrs)
+ (setf current-namespace-declarations new-b)
(if (eq cat :stag)
(lambda ()
(klacks/element-2 source input n-b cont))
@@ -297,19 +299,20 @@
(with-source (source current-key current-values current-attributes)
(setf current-key :end-element)
(setf current-attributes nil)
- ;; fixme: (undeclare-namespaces new-b)
(validate-end-element *ctx* (third current-values))
cont))
(defun klacks/element-2 (source input n-b cont)
(with-source (source
- current-key current-values current-attributes namespace-stack)
- (let ((values* current-values))
+ current-key current-values current-attributes namespace-stack
+ current-namespace-declarations)
+ (let ((values* current-values)
+ (new-b current-namespace-declarations))
(setf current-attributes nil)
(push n-b namespace-stack)
(let ((finish
(lambda ()
- (pop namespace-stack)
+ (setf current-namespace-declarations new-b)
(klacks/element-3 source input values* cont))))
(klacks/content source input finish)))))
@@ -319,7 +322,6 @@
(setf current-values tag-values)
(let ((qname (third tag-values)))
(p/etag input qname)
- ;; fixme: (undeclare-namespaces new-b)
(validate-end-element *ctx* qname))
cont))
@@ -479,6 +481,23 @@
(defmethod klacks:current-xml-base ((source cxml-source))
(car (base-stack (slot-value source 'context))))
+(defmethod klacks:map-current-namespace-declarations (fn (source cxml-source))
+ (loop
+ for (prefix . uri) in (slot-value source 'current-namespace-declarations)
+ do
+ (funcall fn prefix uri)))
+
+(defmethod klacks:find-namespace-binding (prefix (source cxml-source))
+ (with-source (source)
+ (find-namespace-binding prefix)))
+
+(defmethod klacks:decode-qname (qname (source cxml-source))
+ (with-source (source)
+ (multiple-value-bind (prefix local-name) (split-qname qname)
+ (values (and prefix (find-namespace-binding prefix))
+ local-name
+ prefix))))
+
;;;; debugging
--- /project/cxml/cvsroot/cxml/klacks/klacks.lisp 2007/03/04 21:41:07 1.6
+++ /project/cxml/cvsroot/cxml/klacks/klacks.lisp 2007/04/22 13:23:55 1.7
@@ -39,12 +39,17 @@
;;;(defgeneric klacks:current-qname (source))
;;;(defgeneric klacks:current-characters (source))
(defgeneric klacks:current-cdata-section-p (source))
+(defgeneric klacks:map-current-namespace-declarations (fn source))
+(defgeneric klacks:map-previous-namespace-declarations (fn source))
(defgeneric klacks:current-line-number (source))
(defgeneric klacks:current-column-number (source))
(defgeneric klacks:current-system-id (source))
(defgeneric klacks:current-xml-base (source))
+(defgeneric klacks:find-namespace-binding (prefix source))
+(defgeneric klacks:decode-qname (qname source))
+
(defmacro klacks:with-open-source ((var source) &body body)
`(let ((,var ,source))
(unwind-protect
@@ -74,12 +79,14 @@
(check-type key (member :characters))
characters))
-(defun klacks:serialize-event (source handler)
+(defun klacks:serialize-event (source handler &key (consume t))
(multiple-value-bind (key a b c) (klacks:peek source)
(let ((result nil))
(case key
(:start-document
- (sax:start-document handler))
+ (sax:start-document handler)
+ (loop for (prefix . uri) in *initial-namespace-bindings* do
+ (sax:start-prefix-mapping handler prefix uri)))
(:characters
(cond
((klacks:current-cdata-section-p source)
@@ -108,16 +115,28 @@
(slot-value source 'dom-impl-entity-resolver))
(sax::dtd handler (slot-value source 'dom-impl-dtd)))
(:start-element
+ (klacks:map-current-namespace-declarations
+ (lambda (prefix uri)
+ (sax:start-prefix-mapping handler prefix uri))
+ source)
(sax:start-element handler a b c (klacks:list-attributes source)))
(:end-element
- (sax:end-element handler a b c))
+ (sax:end-element handler a b c)
+ (klacks:map-current-namespace-declarations
+ (lambda (prefix uri)
+ (declare (ignore uri))
+ (sax:end-prefix-mapping handler prefix))
+ source))
(:end-document
+ (loop for (prefix . nil) in *initial-namespace-bindings* do
+ (sax:end-prefix-mapping handler prefix))
(setf result (sax:end-document handler)))
((nil)
(error "serialize-event read past end of document"))
(t
(error "unexpected klacks key: ~A" key)))
- (klacks:consume source)
+ (when consume
+ (klacks:consume source))
result)))
(defun serialize-declaration-kludge (list handler)
--- /project/cxml/cvsroot/cxml/klacks/package.lisp 2007/03/04 21:41:07 1.4
+++ /project/cxml/cvsroot/cxml/klacks/package.lisp 2007/04/22 13:23:55 1.5
@@ -21,6 +21,8 @@
(:export #:source
#:close-source
#:with-open-source
+ #:tapping-source
+ #:make-tapping-source
#:peek
#:peek-value
@@ -40,6 +42,7 @@
#:current-qname
#:current-characters
#:current-cdata-section-p
+ #:map-current-namespace-declarations
#:serialize-event
#:serialize-element
@@ -50,4 +53,7 @@
#:current-line-number
#:current-column-number
#:current-system-id
- #:current-xml-base))
+ #:current-xml-base
+
+ #:find-namespace-binding
+ #:decode-qname))
--- /project/cxml/cvsroot/cxml/klacks/tap-source.lisp 2007/04/22 13:23:55 NONE
+++ /project/cxml/cvsroot/cxml/klacks/tap-source.lisp 2007/04/22 13:23:55 1.1
;;; -*- Mode: Lisp; readtable: runes; -*-
;;; (c) copyright 2007 David Lichteblau
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
(in-package :cxml)
(defun klacks:make-tapping-source (upstream-source &optional sax-handler)
(make-instance 'klacks:tapping-source
:upstream-source upstream-source
:dribble-handler sax-handler))
(defclass klacks:tapping-source (klacks:source)
((upstream-source :initarg :upstream-source :accessor upstream-source)
(dribble-handler :initarg :dribble-handler :accessor dribble-handler)
(seen-event-p :initform nil :accessor seen-event-p)))
(defmethod initialize-instance :after ((instance klacks:tapping-source) &key)
(let ((s-p (make-instance 'klacksax :source (upstream-source instance))))
(sax:register-sax-parser (dribble-handler instance) s-p)))
;;; event dribbling
(defun maybe-dribble (source)
(unless (seen-event-p source)
(klacks:serialize-event (upstream-source source)
(dribble-handler source)
:consume nil)
(setf (seen-event-p source) t)))
(defmethod klacks:peek ((source klacks:tapping-source))
(multiple-value-prog1
(klacks:peek (upstream-source source))
(maybe-dribble source)))
(defmethod klacks:peek-value ((source klacks:tapping-source))
(multiple-value-prog1
(klacks:peek-value (upstream-source source))
(maybe-dribble source)))
(defmethod klacks:peek-next ((source klacks:tapping-source))
(setf (seen-event-p source) nil)
(multiple-value-prog1
(klacks:peek-next (upstream-source source))
(maybe-dribble source)))
(defmethod klacks:consume ((source klacks:tapping-source))
(maybe-dribble source)
(multiple-value-prog1
(klacks:consume (upstream-source source))
(setf (seen-event-p source) nil)))
;;; loop through
(defmethod klacks:close-source ((source klacks:tapping-source))
(klacks:close-source (upstream-source source)))
(defmethod klacks:map-attributes (fn (source klacks:tapping-source))
(klacks:map-attributes fn (upstream-source source)))
(defmethod klacks:map-current-namespace-declarations
(fn (source klacks:tapping-source))
(klacks:map-current-namespace-declarations fn (upstream-source source)))
(defmethod klacks:list-attributes ((source klacks:tapping-source))
(klacks:list-attributes (upstream-source source)))
(defmethod klacks:current-line-number ((source klacks:tapping-source))
(klacks:current-line-number (upstream-source source)))
(defmethod klacks:current-column-number ((source klacks:tapping-source))
(klacks:current-column-number (upstream-source source)))
(defmethod klacks:current-system-id ((source klacks:tapping-source))
(klacks:current-system-id (upstream-source source)))
(defmethod klacks:current-xml-base ((source klacks:tapping-source))
(klacks:current-xml-base (upstream-source source)))
(defmethod klacks:current-cdata-section-p ((source klacks:tapping-source))
(klacks:current-cdata-section-p (upstream-source source)))
(defmethod klacks:find-namespace-binding
(prefix (source klacks:tapping-source))
(klacks:find-namespace-binding prefix (upstream-source source)))
(defmethod klacks:decode-qname (qname (source klacks:tapping-source))
(klacks:decode-qname qname (upstream-source source)))
