rel-2007-02-18
+
+ 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. fn is called only for each declaration with two + arguments, the prefix and uri. +
+
+
-
+ You can subclass broadcast-stream 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. +
++ Broadcast handler functions return the result of calling the event + function on the last handler in the list. In particular, + the overall result from sax:end-document will be ignored + for all other handlers. +
+ ++
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)))