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))) ,@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))))