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