Author: hhubner Date: Mon Feb 18 05:36:28 2008 New Revision: 2530
Modified: branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp Log: refactor, remove warnings
Modified: branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp Mon Feb 18 05:36:28 2008 @@ -12,43 +12,14 @@ (defmacro with-xml-export* ((&key output indentation canonical) &body body) `(let ((*objects-written* (make-hash-table :test #'equal)) (cxml::*current-element* nil) - (cxml::*sink* #+(or) (cxml:make-character-stream-sink ,output - :indentation ,indentation :canonical ,canonical))) + (cxml::*sink* (cxml:make-character-stream-sink ,output + :indentation ,indentation :canonical ,canonical))) ,@body))
(defmacro with-xml-export (nil &body body) `(with-xml-export* (:output *standard-output* :indentation 1 :canonical nil) ,@body))
-(defgeneric write-to-xml (object &key name no-recurse) - (:documentation "Write object to XML stream")) - -(defmethod write-to-xml ((object (eql nil)) &key name no-recurse) - (declare (ignore name))) - -(defmethod write-to-xml ((object list) &key (name (error "Can not serialize list to XML without an element name~%")) no-recurse) - (sax:start-element cxml::*sink* nil nil (cxml::string-rod name) nil) - (dolist (obj object) - (write-to-xml obj)) - (sax:end-element cxml::*sink* nil nil (cxml::string-rod name))) - -(defmethod write-to-xml ((object string) &key (name (error "Can not serialize string ~A to XML without an element name." object)) no-recurse) - (sax:start-element cxml::*sink* nil nil (cxml::string-rod name) nil) - (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 (class-slots (class-of object))) - (cxml:with-element (string-downcase (symbol-name (slot-definition-name slot))) - (let ((value (slot-value object (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) @@ -58,65 +29,92 @@ :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 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. - - (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. - - (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))))))) - - ;; 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))))))) +(defgeneric write-to-xml (object &key) + (:documentation "Write OBJECT to XML stream") + + (:method ((object (eql nil)) &key)) + + (:method ((object list) &key (name (error "Can not serialize list to XML without an element name~%"))) + (sax:start-element cxml::*sink* nil nil (cxml::string-rod name) nil) + (dolist (obj object) + (write-to-xml obj)) + (sax:end-element cxml::*sink* nil nil (cxml::string-rod name))) + + (:method ((object string) &key (name (error "Can not serialize string ~A to XML without an element name." object))) + (sax:start-element cxml::*sink* nil nil (cxml::string-rod name) nil) + (sax:characters cxml::*sink* (cxml::string-rod object)) + (sax:end-element cxml::*sink* nil nil (cxml::string-rod name))) + + (:method ((object standard-object) &key) + (cxml:with-element (string-downcase (class-name (class-of object))) + (dolist (slot (class-slots (class-of object))) + (cxml:with-element (string-downcase (symbol-name (slot-definition-name slot))) + (let ((value (slot-value object (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]")))))))))) + + (:method ((object xml-class) &key name) + (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. + + (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. + + (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))) + (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))))))) - (sax:end-element cxml::*sink* nil nil qname)))) + (sax:end-element cxml::*sink* nil nil qname)))))