[bknr-cvs] r2530 - branches/trunk-reorg/bknr/datastore/src/xml-impex
hhubner at common-lisp.net
hhubner at common-lisp.net
Mon Feb 18 10:36:28 UTC 2008
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)))
, at body))
(defmacro with-xml-export (nil &body body)
`(with-xml-export* (:output *standard-output* :indentation 1 :canonical nil)
, at 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)))))
More information about the Bknr-cvs
mailing list