From b8ba07a9199645d379d0cc22e9624bc4b0a18d9e Mon Sep 17 00:00:00 2001
From: dlichteblau <dlichteblau>
Date: Sun, 22 Apr 2007 13:23:54 +0000
Subject: [PATCH] +      <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>
---
 cxml.asd                |   3 +-
 doc/cxml.css            |  10 ++--
 doc/index.xml           |  12 ++++-
 doc/klacks.xml          |  25 ++++++++++
 doc/sax.xml             |  37 +++++++++++----
 klacks/klacks-impl.lisp |  33 ++++++++++---
 klacks/klacks.lisp      |  27 +++++++++--
 klacks/package.lisp     |   8 +++-
 klacks/tap-source.lisp  | 103 ++++++++++++++++++++++++++++++++++++++++
 xml/package.lisp        |   8 +++-
 xml/sax-proxy.lisp      |  35 +++++++++++---
 11 files changed, 264 insertions(+), 37 deletions(-)
 create mode 100644 klacks/tap-source.lisp

diff --git a/cxml.asd b/cxml.asd
index 64746e2..37bc06b 100644
--- a/cxml.asd
+++ b/cxml.asd
@@ -118,7 +118,8 @@
     :components
     ((:file "package")
      (:file "klacks")
-     (:file "klacks-impl"))
+     (:file "klacks-impl")
+     (:file "tap-source"))
     :depends-on (:cxml-xml))
 
 (asdf:defsystem :cxml-test
diff --git a/doc/cxml.css b/doc/cxml.css
index 5e082c1..8c108a4 100644
--- a/doc/cxml.css
+++ b/doc/cxml.css
@@ -10,10 +10,11 @@ div.sidebar-title {
   background-color: #9c0000;
   border: solid #9c0000;
   border-top-width: 1px;
-  border-bottom-width: 0px;
+  border-bottom-width: 2px;
   border-left-width: 4px;
   border-right-width: 0px;
-  margin: 0em 2pt 1px 2em;
+  padding-left: 1px;
+  margin: 0em 2pt 0px 2em;
 }
 
 div.sidebar-title a {
@@ -21,15 +22,14 @@ div.sidebar-title a {
 }
 
 div.sidebar-main {
-  background-color: #eeeeee;
+  background-color: #f7f7f7;
   border: solid #9c0000;
   border-top-width: 0px;
   border-bottom-width: 0px;
   border-left-width: 4px;
   border-right-width: 0px;
   margin: 0em 2pt 1em 2em;
-  padding-top: 2px;
-  padding-left: 2px;
+  padding: 1em;
 }
 
 div.sidebar ul.main {
diff --git a/doc/index.xml b/doc/index.xml
index 69c450b..5526974 100644
--- a/doc/index.xml
+++ b/doc/index.xml
@@ -55,12 +55,20 @@
       <li>xml:base support (SAX and Klacks only, not yet used in DOM).
       See documentation <a href="sax.html#saxparser">here</a> and <a
       href="klacks.html#locator">here</a>.</li>
-      <li>Fixed attributes to carry an lname even without when occurring
+      <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>
+      <li>Changed attributes to carry an lname even when occurring
       without a namespace.</li>
       <li>Klacks improvements: Incompatibly changed
       klacks:find-element and find-event to consider the current event
       as a result.  Added klacks-error, klacks:expect, klacks:skip,
-      klacks:expecting-element.</li>
+      klacks:expecting-element.  Fixed serialize-event to generate
+      start-prefix-mapping and end-prefix-mapping events.  New function
+      map-current-namespace-declarations.</li>
     </ul>
     <p class="nomargin"><tt>rel-2007-02-18</tt></p>
     <ul class="nomargin">
diff --git a/doc/klacks.xml b/doc/klacks.xml
index 6bd5c0b..ff617dc 100644
--- a/doc/klacks.xml
+++ b/doc/klacks.xml
@@ -179,6 +179,18 @@
      specified using a CDATA section in the source document.  Else,
      signal an error.
     </p>
+    <p>
+      <div class="def">Function KLACKS:MAP-CURRENT-NAMESPACE-DECLARATIONS (fn source) => nil</div>
+    </p>
+    <p>
+     For use only on :start-element and :end-element events, this
+     function report every namespace declaration on the current element.
+     On :start-element, these correspond to the xmlns attributes of the
+     start tag.  On :end-element, the declarations of the corresponding
+     start tag are reported.  No inherited namespaces are
+     included.  <tt>fn</tt> is called only for each declaration with two
+     arguments, the prefix and uri.
+    </p>
     <p>
       <div class="def">Function KLACKS:MAP-ATTRIBUTES (fn source)</div>
     </p>
@@ -281,6 +293,19 @@
       Read all klacks events from <tt>source</tt> and send them as SAX
       events to the SAX <tt>handler</tt>.
     </p>
+    <p>
+      <div class="def">Class KLACKS:TAPPING-SOURCE (source)</div>
+      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.
+    </p>
+    <p>
+      <div class="def">Functon KLACKS:MAKE-TAPPING-SOURCE
+      (upstream-source &amp;optional sax-handler)</div>
+      Create a tapping source relaying events
+      for <tt>upstream-source</tt>, and sending SAX events
+      to <tt>sax-handler</tt>.
+    </p>
 
     <a name="locator"/>
     <h3>Location information</h3>
diff --git a/doc/sax.xml b/doc/sax.xml
index 9fc3937..e68ead7 100644
--- a/doc/sax.xml
+++ b/doc/sax.xml
@@ -358,16 +358,35 @@
   (dom:map-document (cxml:make-validator x #"foo") d))</pre>
 
     <p>
-      <div class="def">Class CXML:SAX-PROXY ()</div>
+      <div class="def">Class CXML:BROADCAST-HANDLER ()</div>
+      <div class="def">Accessor CXML:BROADCAST-HANDLER-HANDLERS</div>
+      <div class="def">Function CXML:MAKE-BROADCAST-HANDLER (&amp;rest handlers)</div>
+      <tt>broadcast-handler</tt> is a SAX handler which passes every event it
+      receives on to each of several chained handlers, somewhat similar
+      to the way a <tt>broadcast-stream</tt> works.
+    </p>
+    <p>
+      You can subclass <tt>broadcast-stream</tt> to modify the events
+      before they are being passed on.  Define methods on your handler
+      class for the events to be modified.  All other events will pass
+      through to the chained handlers unmodified.
+    </p>
+    <p>
+      Broadcast handler functions return the result of calling the event
+      function on the <i>last</i> handler in the list.  In particular,
+      the overall result from <tt>sax:end-document</tt> will be ignored
+      for all other handlers.
+    </p>
+
+    <p>
+      <div class="def">Class CXML:SAX-PROXY (broadcast-handler)</div>
       <div class="def">Accessor CXML:PROXY-CHAINED-HANDLER</div>
-      <tt>sax-proxy</tt> is a SAX handler which passes all events it
-      receives on to a user-defined second handler, which defaults
-      to <tt>nil</tt>.  Use <tt>sax-proxy</tt> to modify the events a
-      SAX handler receives by defining your own subclass
-      of <tt>sax-proxy</tt>.  Setting the chained handler to the target
-      handler, and define methods on your handler class for the events
-      to be modified.  All other events will pass through to the chained
-      handler unmodified.
+      <tt>sax-proxy</tt> is a subclass of <tt>broadcast-handler</tt>
+      which sends events to exactly one chained handler.  This class is
+      still included for compatibility with older versions of
+      CXML which did not include the more
+      general <tt>broadcast-handler</tt> yet, but has been retrofitted
+      as a subclass of the latter.
     </p>
 
     <p>
diff --git a/klacks/klacks-impl.lisp b/klacks/klacks-impl.lisp
index 8f91775..266cc9f 100644
--- a/klacks/klacks-impl.lisp
+++ b/klacks/klacks-impl.lisp
@@ -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
 
diff --git a/klacks/klacks.lisp b/klacks/klacks.lisp
index 530474e..69f9a34 100644
--- a/klacks/klacks.lisp
+++ b/klacks/klacks.lisp
@@ -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)
diff --git a/klacks/package.lisp b/klacks/package.lisp
index 44009f3..8ac34dc 100644
--- a/klacks/package.lisp
+++ b/klacks/package.lisp
@@ -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))
diff --git a/klacks/tap-source.lisp b/klacks/tap-source.lisp
new file mode 100644
index 0000000..d92f98c
--- /dev/null
+++ b/klacks/tap-source.lisp
@@ -0,0 +1,103 @@
+;;; -*- 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)))
diff --git a/xml/package.lisp b/xml/package.lisp
index 97d0c5a..c082be1 100644
--- a/xml/package.lisp
+++ b/xml/package.lisp
@@ -78,11 +78,15 @@
    #:resolve-extid
    
    #:make-recoder
-   #:sax-proxy
-   #:proxy-chained-handler
    #:make-namespace-normalizer
    #:make-whitespace-normalizer
    #:rod-to-utf8-string
    #:utf8-string-to-rod
 
+   #:broadcast-handler
+   #:broadcast-handler-handlers
+   #:make-broadcast-handler
+   #:sax-proxy
+   #:proxy-chained-handler
+
    #:make-source))
diff --git a/xml/sax-proxy.lisp b/xml/sax-proxy.lisp
index 4db10f0..bd1d18c 100644
--- a/xml/sax-proxy.lisp
+++ b/xml/sax-proxy.lisp
@@ -8,14 +8,33 @@
 
 (in-package :cxml)
 
-(defclass sax-proxy ()
-  ((chained-handler :initform nil
-                    :initarg :chained-handler
-                    :accessor proxy-chained-handler)))
+(defclass broadcast-handler ()
+  ((handlers :initform nil
+	     :initarg :handlers
+	     :accessor broadcast-handler-handlers)))
+
+(defun make-broadcast-handler (&rest handlers)
+  (make-instance 'broadcast-handler :handlers handlers))
+
+(defclass sax-proxy (broadcast-handler)
+  ())
+
+(defmethod initialize-instance
+    :after ((instance sax-proxy) &key chained-handler)
+  (setf (proxy-chained-handler instance) chained-handler))
+
+(defmethod proxy-chained-handler ((instance sax-proxy))
+  (car (broadcast-handler-handlers instance)))
+
+(defmethod (setf proxy-chained-handler) (newval (instance sax-proxy))
+  (setf (broadcast-handler-handlers instance) (list newval)))
 
 (macrolet ((define-proxy-method (name (&rest args))
-             `(defmethod ,name ((handler sax-proxy) ,@args)
-                (,name (proxy-chained-handler handler) ,@args))))
+             `(defmethod ,name ((handler broadcast-handler) ,@args)
+                (let (result)
+		  (dolist (next (broadcast-handler-handlers handler))
+		    (setf result (,name next ,@args)))
+		  result))))
   (define-proxy-method sax:start-document ())
   (define-proxy-method sax:start-element (uri lname qname attributes))
   (define-proxy-method sax:start-prefix-mapping (prefix uri))
@@ -39,3 +58,7 @@
   (define-proxy-method sax:attribute-declaration (elt attr type default))
   (define-proxy-method sax:entity-resolver (resolver))
   (define-proxy-method sax::dtd (dtd)))
+
+(defmethod sax:register-sax-parser :after ((handler sax-proxy) parser)
+  (dolist (next (broadcast-handler-handlers handler))
+    (sax:register-sax-parser next parser)))