[bknr-cvs] r1871 - in branches/xml-class-rework/bknr/src: . xml-impex
bknr at bknr.net
bknr at bknr.net
Thu Feb 23 06:35:30 UTC 2006
Author: hhubner
Date: 2006-02-23 00:35:29 -0600 (Thu, 23 Feb 2006)
New Revision: 1871
Modified:
branches/xml-class-rework/bknr/src/packages.lisp
branches/xml-class-rework/bknr/src/xml-impex/package.lisp
branches/xml-class-rework/bknr/src/xml-impex/xml-class.lisp
branches/xml-class-rework/bknr/src/xml-impex/xml-export.lisp
Log:
Another commit of the DTD-less xml-impex. The current version is able
to export objects with references, objects which have a unique-id-slot
specified in their classes are exported only once. The print-to-xml
function has been converted to a generic function in order to be able
to specialize it for arbitary objects. This makes it possible to
serialize objects to XML which do not have xml-class as metaclass of their
class. I'm not sure whether this is really a good idea or if it makes
the whole thing less intuitive.
Next, I will check the XML specifications to see whether a standardized
mechanism to serialize object references into XML exists.
Modified: branches/xml-class-rework/bknr/src/packages.lisp
===================================================================
--- branches/xml-class-rework/bknr/src/packages.lisp 2006-02-23 06:29:32 UTC (rev 1870)
+++ branches/xml-class-rework/bknr/src/packages.lisp 2006-02-23 06:35:29 UTC (rev 1871)
@@ -128,9 +128,17 @@
#:user-preferences
#:user-subscriptions
+ ;; Export slot names so that derived classes can overload
+ ;; slots (e.g. to add XML impex attributes)
+ #:login
+ #:flags
+ #:email
#:full-name
- #:email
+ #:last-login
#:password
+ #:preferences
+ #:subscriptions
+ #:mail-error
#:find-user
#:user-with-email
@@ -271,6 +279,7 @@
#:website-menu
#:website-url
#:website-session-info
+ #:website-base-href
#:host
#:publish-site
#:publish-handler
Modified: branches/xml-class-rework/bknr/src/xml-impex/package.lisp
===================================================================
--- branches/xml-class-rework/bknr/src/xml-impex/package.lisp 2006-02-23 06:29:32 UTC (rev 1870)
+++ branches/xml-class-rework/bknr/src/xml-impex/package.lisp 2006-02-23 06:35:29 UTC (rev 1871)
@@ -20,5 +20,9 @@
#:write-to-xml
#:xml-class-importer
+ #:with-xml-export
+ #:with-xml-export*
+ #:write-to-xml
+
#:create-instance
#:set-slot-value))
Modified: branches/xml-class-rework/bknr/src/xml-impex/xml-class.lisp
===================================================================
--- branches/xml-class-rework/bknr/src/xml-impex/xml-class.lisp 2006-02-23 06:29:32 UTC (rev 1870)
+++ branches/xml-class-rework/bknr/src/xml-impex/xml-class.lisp 2006-02-23 06:35:29 UTC (rev 1871)
@@ -20,26 +20,38 @@
(defmethod validate-superclass ((sub xml-class) (super indexed-class))
t)
+(defun princ-to-string-1 (object)
+ (when object
+ (princ-to-string object)))
+
(defclass xml-direct-slot-definition (bknr.indices::index-direct-slot-definition)
- ((attribute :initarg :attribute
- :initform nil
- :documentation "Name of attribute to use to impex the slot.")
- (element :initarg :element
- :initform nil
- :documentation "Name of the element to use to impex the slot.")
- (body :initarg :body
- :initform nil
- :documentation "Whether the value of the slot has to be stored in the body of the class element.")
+ ((attribute :initarg :attribute
+ :initform nil
+ :documentation "Name of attribute to use to impex the slot.")
+ (element :initarg :element
+ :initform nil
+ :documentation "Name of the element to use to impex the slot.")
+ (body :initarg :body
+ :initform nil
+ :documentation "Whether the value of the slot has to be stored in the body of the class element.")
(containment :initarg :containment
:initform nil
:documentation "Containment specification for this slot, either nil, :* or :+")
- (parser :initarg :parser
- :initform #'identity
- :documentation "Function used to parse the slot value from the XML string.")
- (serializer :initarg :serializer
- :initform #'princ-to-string
- :documentation "Function used to serialize the slot back to XML.")
-
+ (parser :initarg :parser
+ :initform #'identity
+ :documentation "Function used to parse the slot value from the XML string.")
+ (serializer :initarg :serializer
+ :initform #'princ-to-string-1
+ :documentation "Function used to serialize the slot back to XML.")
+
+ (object-id-slot :initarg :object-id-slot
+ :initform nil
+ :documentation "If this slot is non-nil, the slot's
+value is considered to be the unique object id of the object. During
+export, objects which have an object-id-slot will only be serialized
+once. Further occurances of the same object will be referenced
+through the object-id-slot (either an element or an attribute)")
+
(id-to-object :initarg :id-to-object
:initform nil
:documentation "Function used to get the value pointed to by the ID.")
@@ -47,9 +59,9 @@
:initform nil
:documentation "Function used to get the ID of the object stored in the slot.")
- (parent :initarg :parent
- :initform nil
- :documentation "Slot is a pointer to the parent object.")))
+ (parent :initarg :parent
+ :initform nil
+ :documentation "Slot is a pointer to the parent object.")))
(defclass xml-effective-slot-definition (bknr.indices::index-effective-slot-definition)
((body :initform nil)
@@ -58,6 +70,8 @@
(parser :initform nil :reader xml-effective-slot-definition-parser)
(serializer :initform nil :reader xml-effective-slot-definition-serializer)
+
+ (object-id-slot :initform nil :reader xml-effective-slot-definition-object-id-slot)
(id-to-object :initform nil)
(object-to-id :initform nil)
@@ -69,7 +83,7 @@
(defmethod print-object ((slot xml-effective-slot-definition) stream)
(print-unreadable-object (slot stream :type t :identity t)
(with-slots (attribute element body parent) slot
- (format stream "~A (~A~@[~S~])" (slot-definition-name slot)
+ (format stream "~A (~A~@[ ~S~])" (slot-definition-name slot)
(cond (attribute "ATTRIBUTE")
(element "ELEMENT")
(body "BODY")
@@ -128,11 +142,8 @@
(unless (class-finalized-p class)
(finalize-inheritance class))
- (let ((slots (class-slots class))
- (elmdef (xml-class-element class)))
+ (class-slots class))
- slots))
-
(defmethod direct-slot-definition-class ((class xml-class) &key parent attribute element body &allow-other-keys)
(if (or attribute element body parent)
'xml-direct-slot-definition
@@ -142,13 +153,15 @@
(declare (ignore initargs))
'xml-effective-slot-definition)
-(defmethod compute-effective-slot-definition :around
- ((class xml-class) name direct-slots)
+(defmethod compute-effective-slot-definition :around ((class xml-class) name direct-slots)
(let* ((xml-directs (remove-if-not #'(lambda (class) (typep class 'xml-direct-slot-definition))
direct-slots))
(xml-direct (first xml-directs)))
+
(when (> (length xml-directs) 1)
- (error "Can't overload slots with xml options."))
+ (dolist (slot-def (class-slots (class-of (first xml-directs))))
+ (unless (apply #'equal (mapcar #'(lambda (slot) (slot-value slot (slot-definition-name slot-def))) xml-directs))
+ (warn "Possibly conflicting slot options for overloaded slot ~A." (slot-definition-name slot-def)))))
(let ((normal-slot (call-next-method)))
(when (and xml-direct
@@ -172,7 +185,7 @@
(setf (slot-value normal-slot slot)
(slot-value xml-direct slot))))
- (dolist (slot '(parser serializer object-to-id id-to-object) normal-slot)
+ (dolist (slot '(parser serializer object-id-slot object-to-id id-to-object) normal-slot)
(let ((value (slot-value normal-slot slot)))
(when value
(setf (slot-value normal-slot slot)
Modified: branches/xml-class-rework/bknr/src/xml-impex/xml-export.lisp
===================================================================
--- branches/xml-class-rework/bknr/src/xml-impex/xml-export.lisp 2006-02-23 06:29:32 UTC (rev 1870)
+++ branches/xml-class-rework/bknr/src/xml-impex/xml-export.lisp 2006-02-23 06:35:29 UTC (rev 1871)
@@ -7,83 +7,106 @@
(when serializer
(setf value (funcall serializer value)))))
-(defun write-to-xml (object &key sink name (string-rod-fn #'cxml::string-rod))
- (unless sink
- (setf sink (if (boundp 'cxml::*sink*)
- cxml::*sink*
- (cxml:make-character-stream-sink *standard-output*
- :indentation 3 :canonical nil))))
+(defvar *objects-written*)
- (cond ((listp object)
- (unless name
- (error "No element name was given~%"))
- (sax:start-element sink nil nil (funcall string-rod-fn name) nil)
- (dolist (obj object)
- (write-to-xml obj :sink sink :string-rod-fn string-rod-fn))
- (sax:end-element sink nil nil (funcall string-rod-fn name)))
+(defmacro with-xml-export* ((&key output indentation canonical) &body body)
+ `(let ((*objects-written* (make-hash-table :test #'equal))
+ (cxml::*sink* (cxml:make-character-stream-sink ,output
+ :indentation ,indentation :canonical ,canonical)))
+ , at body))
- ((typep (class-of object) 'xml-class)
- (xml-object-check-validity object)
- (let ((class (class-of object)))
- (unless (typep class 'xml-class)
- (error "~a is not of metaclass XML-CLASS." object))
- (unless (xml-class-element class)
- (error "Class ~a has no element definition." class))
-
- (let* ((attr-slots (xml-class-attribute-slots class))
- (elt-slots (xml-class-element-slots class))
- (body-slot (xml-class-body-slot class))
- (qname (cxml::string-rod (xml-class-element 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
- (funcall string-rod-fn
- (slot-serialize-value slot (slot-value object name)))))))
- (sax:start-element sink nil nil qname attributes)
+(defmacro with-xml-export (nil &body body)
+ `(with-xml-export* (:output *standard-output* :indentation 1 :canonical nil)
+ , at body))
- ;; elements
- (dolist (slot elt-slots)
- (let ((name (slot-definition-name slot))
- (elmdef-name (cxml::rod-string
- (cxml::elmdef-name
- (xml-effective-slot-definition-element slot))))
- (containment (xml-effective-slot-definition-containment slot)))
- (when (slot-boundp object name)
- (if (member containment '(:+ :*))
- (dolist (child (slot-value object name))
- (if (typep (class-of child) 'xml-class)
- (write-to-xml child :sink sink :string-rod-fn string-rod-fn)
- (write-to-xml (slot-serialize-value slot child)
- :sink sink :name elmdef-name :string-rod-fn string-rod-fn)))
- (let ((child (slot-value object name)))
- (if (typep (class-of child) 'xml-class)
- (write-to-xml child :sink sink :string-rod-fn string-rod-fn)
- (write-to-xml (slot-serialize-value slot child)
- :sink sink :name elmdef-name :string-rod-fn string-rod-fn)))))))
+(defgeneric write-to-xml (object &key name no-recurse)
+ (:documentation "Write object to XML stream"))
- ;; body slot
- (when body-slot
- (let ((name (slot-definition-name body-slot)))
- (when (slot-boundp object name)
- (sax:characters
- sink
- (funcall string-rod-fn
- (funcall (xml-effective-slot-definition-serializer body-slot)
- (slot-value object name)))))))
-
- (sax:end-element sink nil nil qname))))
+(defmethod write-to-xml ((object (eql nil)) &key name no-recurse)
+ (declare (ignore name)))
- ((stringp object)
- (unless name
- (error "Can not serialize string ~A to XML without an element name." object))
- (sax:start-element sink nil nil (funcall string-rod-fn name) nil)
- (sax:characters sink (funcall string-rod-fn object))
- (sax:end-element sink nil nil (funcall string-rod-fn 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)))
- (t (error "Can not serialize unknown object ~A." object))))
+(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)))
+
+(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)
+ (error "Slot ~A is not defined as :attribute slot and cannot be used as unique-id slot for class ~A" unique-id-slot-name (class-name class)))
+ (sax:start-element cxml::*sink* nil nil name
+ (list (sax:make-attribute :qname (cxml::string-rod (xml-effective-slot-definition-attribute slotdef))
+ :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)))))
+
+ ;; 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)))))))
+
+ (sax:end-element cxml::*sink* nil nil qname))))
+ (t nil)))))
More information about the Bknr-cvs
mailing list