[bknr-cvs] r2149 - in trunk/bknr/src: . web xml-impex
bknr at bknr.net
bknr at bknr.net
Sun Apr 15 07:07:17 UTC 2007
Author: hhubner
Date: 2007-04-15 03:07:16 -0400 (Sun, 15 Apr 2007)
New Revision: 2149
Modified:
trunk/bknr/src/packages.lisp
trunk/bknr/src/web/web-server-event.lisp
trunk/bknr/src/xml-impex/xml-export.lisp
Log:
Add method to render arbitary objects as XML, mainly for log inspection.
Modified: trunk/bknr/src/packages.lisp
===================================================================
--- trunk/bknr/src/packages.lisp 2007-04-15 05:44:31 UTC (rev 2148)
+++ trunk/bknr/src/packages.lisp 2007-04-15 07:07:16 UTC (rev 2149)
@@ -283,7 +283,7 @@
#:website-hosts
#:website-authorizer
#:website-show-page
- #:website-show-error
+ #:website-show-error-page
#:website-handler-definitions
#:website-admin-navigation
#:website-navigation
Modified: trunk/bknr/src/web/web-server-event.lisp
===================================================================
--- trunk/bknr/src/web/web-server-event.lisp 2007-04-15 05:44:31 UTC (rev 2148)
+++ trunk/bknr/src/web/web-server-event.lisp 2007-04-15 07:07:16 UTC (rev 2149)
@@ -27,7 +27,7 @@
(backtrace :read))
(:documentation "Backtrace when an error happens inside a web page"))
-(defmethod print-object ((event web-server-error-event) streaM)
+(defmethod print-object ((event web-server-error-event) stream)
(format stream "#<~a at ~a error ~a>"
(class-name (class-of event))
(format-date-time (event-time event))
Modified: trunk/bknr/src/xml-impex/xml-export.lisp
===================================================================
--- trunk/bknr/src/xml-impex/xml-export.lisp 2007-04-15 05:44:31 UTC (rev 2148)
+++ trunk/bknr/src/xml-impex/xml-export.lisp 2007-04-15 07:07:16 UTC (rev 2149)
@@ -11,6 +11,7 @@
(defmacro with-xml-export* ((&key output indentation canonical) &body body)
`(let ((*objects-written* (make-hash-table :test #'equal))
+ (cxml::*current-element* nil)
(cxml::*sink* (cxml:make-character-stream-sink ,output
:indentation ,indentation :canonical ,canonical)))
, at body))
@@ -36,6 +37,18 @@
(sax:characters cxml::*sink* (cxml::string-rod object))
(sax:end-element cxml::*sink* nil nil (cxml::string-rod name)))
+(defmethod write-to-xml ((object standard-object) &key &allow-other-keys)
+ (cxml:with-element (string-downcase (class-name (class-of object)))
+ (dolist (slot (pcl:class-slots (class-of object)))
+ (cxml:with-element (string-downcase (symbol-name (pcl:slot-definition-name slot)))
+ (let ((value (slot-value object (pcl:slot-definition-name slot))))
+ (when value
+ (cxml:text (handler-case
+ (cxml::utf8-string-to-rod (princ-to-string value))
+ (error (e)
+ (declare (ignore e))
+ (cxml::utf8-string-to-rod "[unprintable]"))))))))))
+
(defun write-object-reference (class object unique-id-slot-name name)
(let ((slotdef (find unique-id-slot-name (class-slots class) :key #'slot-definition-name)))
(unless (xml-effective-slot-definition-attribute slotdef)
@@ -45,68 +58,65 @@
:value (cxml::string-rod (slot-serialize-value slotdef (slot-value object unique-id-slot-name))))))
(sax:end-element cxml::*sink* nil nil name)))
-(defmethod write-to-xml ((object t) &key name no-recurse)
- (let ((class (class-of object)))
- (cond
- ((typep class 'xml-class)
- (xml-object-check-validity object)
- (let ((qname (cxml::string-rod (or name (xml-class-element class)))))
+(defmethod write-to-xml ((object xml-class) &key name no-recurse)
+ (xml-object-check-validity object)
+ (let* ((class (class-of object))
+ (qname (cxml::string-rod (or name (xml-class-element class)))))
- ;; If this object has been serialized to the XML stream,
- ;; write a reference to the object and return.
+ ;; If this object has been serialized to the XML stream,
+ ;; write a reference to the object and return.
- (with-slots (unique-id-slot) class
- (when unique-id-slot
- (if (gethash (slot-value object (first unique-id-slot)) *objects-written*)
- (progn
- (write-object-reference class object (first unique-id-slot) qname)
- (return-from write-to-xml))
- (setf (gethash (slot-value object (first unique-id-slot)) *objects-written*) t))))
+ (with-slots (unique-id-slot) class
+ (when unique-id-slot
+ (if (gethash (slot-value object (first unique-id-slot)) *objects-written*)
+ (progn
+ (write-object-reference class object (first unique-id-slot) qname)
+ (return-from write-to-xml))
+ (setf (gethash (slot-value object (first unique-id-slot)) *objects-written*) t))))
- ;; Object has not been written to the XML file or no
- ;; unique-id-slot is defined for this class.
+ ;; Object has not been written to the XML file or no
+ ;; unique-id-slot is defined for this class.
- (let* ((attr-slots (xml-class-attribute-slots class))
- (elt-slots (xml-class-element-slots class))
- (body-slot (xml-class-body-slot class))
- ;; attributes
- (attributes (loop for slot in attr-slots
- for name = (slot-definition-name slot)
- for attdef = (cxml::string-rod (xml-effective-slot-definition-attribute slot))
- when (and (slot-boundp object name)
- (slot-value object name))
- collect (sax:make-attribute
- :qname attdef
- :value
- (cxml::string-rod
- (slot-serialize-value slot (slot-value object name)))))))
- (sax:start-element cxml::*sink* nil nil qname attributes)
+ (let* ((attr-slots (xml-class-attribute-slots class))
+ (elt-slots (xml-class-element-slots class))
+ (body-slot (xml-class-body-slot class))
+ ;; attributes
+ (attributes (loop for slot in attr-slots
+ for name = (slot-definition-name slot)
+ for attdef = (cxml::string-rod (xml-effective-slot-definition-attribute slot))
+ when (and (slot-boundp object name)
+ (slot-value object name))
+ collect (sax:make-attribute
+ :qname attdef
+ :value
+ (cxml::string-rod
+ (slot-serialize-value slot (slot-value object name)))))))
+ (sax:start-element cxml::*sink* nil nil qname attributes)
- ;; elements
- (dolist (slot elt-slots)
- (let ((name (slot-definition-name slot))
- (element-name (xml-effective-slot-definition-element slot))
- (containment (xml-effective-slot-definition-containment slot)))
- (when (slot-boundp object name)
- (if (consp (slot-value object name))
- (dolist (child (slot-value object name))
- (if (typep (class-of child) 'xml-class)
- (write-to-xml child)
- (write-to-xml (slot-serialize-value slot child) :name element-name)))
- (let ((child (slot-value object name)))
- (if (typep (class-of child) 'xml-class)
- (write-to-xml child)
- (write-to-xml (slot-serialize-value slot child) :name element-name)))))))
+ ;; elements
+ (dolist (slot elt-slots)
+ (let ((name (slot-definition-name slot))
+ (element-name (xml-effective-slot-definition-element slot))
+ (containment (xml-effective-slot-definition-containment slot)))
+ (when (slot-boundp object name)
+ (if (consp (slot-value object name))
+ (dolist (child (slot-value object name))
+ (if (typep (class-of child) 'xml-class)
+ (write-to-xml child)
+ (write-to-xml (slot-serialize-value slot child) :name element-name)))
+ (let ((child (slot-value object name)))
+ (if (typep (class-of child) 'xml-class)
+ (write-to-xml child)
+ (write-to-xml (slot-serialize-value slot child) :name element-name)))))))
- ;; body slot
- (when body-slot
- (let ((name (slot-definition-name body-slot)))
- (when (slot-boundp object name)
- (sax:characters
- cxml::*sink*
- (cxml::string-rod
- (funcall (xml-effective-slot-definition-serializer body-slot)
- (slot-value object name)))))))
+ ;; body slot
+ (when body-slot
+ (let ((name (slot-definition-name body-slot)))
+ (when (slot-boundp object name)
+ (sax:characters
+ cxml::*sink*
+ (cxml::string-rod
+ (funcall (xml-effective-slot-definition-serializer body-slot)
+ (slot-value object name)))))))
- (sax:end-element cxml::*sink* nil nil qname))))
- (t nil))))
+ (sax:end-element cxml::*sink* nil nil qname))))
More information about the Bknr-cvs
mailing list