Update of /project/cl-prevalence/cvsroot/cl-prevalence/src In directory common-lisp.net:/tmp/cvs-serv23652/src

Modified Files: serialization.lisp Log Message: added code to deal with unbound slots when serializing (noted by anthony juckel) and code to deal with missing slots when deserializing

Date: Mon Oct 4 17:13:15 2004 Author: scaekenberghe

Index: cl-prevalence/src/serialization.lisp diff -u cl-prevalence/src/serialization.lisp:1.5 cl-prevalence/src/serialization.lisp:1.6 --- cl-prevalence/src/serialization.lisp:1.5 Mon Oct 4 16:41:37 2004 +++ cl-prevalence/src/serialization.lisp Mon Oct 4 17:13:15 2004 @@ -1,6 +1,6 @@ ;;;; -*- mode: Lisp -*- ;;;; -;;;; $Id: serialization.lisp,v 1.5 2004/10/04 14:41:37 scaekenberghe Exp $ +;;;; $Id: serialization.lisp,v 1.6 2004/10/04 15:13:15 scaekenberghe Exp $ ;;;; ;;;; XML and S-Expression based Serialization for Common Lisp and CLOS ;;;; @@ -384,13 +384,13 @@ (write-string "" CLASS="" stream) (print-symbol-xml (class-name (class-of object)) stream) (princ "">" stream) - (mapc #'(lambda (slot) - (write-string "<SLOT NAME="" stream) - (print-symbol-xml slot stream) - (write-string "">" stream) - (serialize-xml-internal (slot-value object slot) stream serialization-state) - (write-string "</SLOT>" stream)) - (get-serializable-slots serialization-state object)) + (loop :for slot :in (get-serializable-slots serialization-state object) + :do (when (slot-boundp object slot) + (write-string "<SLOT NAME="" stream) + (print-symbol-xml slot stream) + (write-string "">" stream) + (serialize-xml-internal (slot-value object slot) stream serialization-state) + (write-string "</SLOT>" stream))) (write-string "</OBJECT>" stream)))))

(defmethod serialize-sexp-internal ((object standard-object) stream serialization-state) @@ -408,13 +408,13 @@ (print-symbol (class-name (class-of object)) stream) (when serializable-slots (princ " :SLOTS (" stream) - (mapc #'(lambda (slot) - (write-string " (" stream) - (print-symbol slot stream) - (write-string " . " stream) - (serialize-sexp-internal (slot-value object slot) stream serialization-state) - (write-string ")" stream)) - serializable-slots)) + (loop :for slot :in serializable-slots + :do (when (slot-boundp object slot) + (write-string " (" stream) + (print-symbol slot stream) + (write-string " . " stream) + (serialize-sexp-internal (slot-value object slot) stream serialization-state) + (write-string ")" stream)))) (write-string " ) )" stream)))))

;;; Deserialize CLOS instances and Lisp primitives from the XML representation @@ -464,11 +464,13 @@ (:object (let* ((id (parse-integer (get-attribute-value :id attributes))) (object (gethash id *deserialized-objects*))) (dolist (pair seed object) - (setf (slot-value object (car pair)) (cdr pair))))) + (when (slot-exists-p object (car pair)) + (setf (slot-value object (car pair)) (cdr pair)))))) (:struct (let* ((id (parse-integer (get-attribute-value :id attributes))) (object (gethash id *deserialized-objects*))) (dolist (pair seed object) - (setf (slot-value object (car pair)) (cdr pair))))) + (when (slot-exists-p object (car pair)) + (setf (slot-value object (car pair)) (cdr pair)))))) (:hash-table (let* ((id (parse-integer (get-attribute-value :id attributes))) (hash-table (gethash id *deserialized-objects*))) (dolist (pair seed hash-table) @@ -505,16 +507,18 @@ (let ((object (make-instance class))) (setf (gethash id deserialized-objects) object) (dolist (slot slots) - (setf (slot-value object (first slot)) - (deserialize-sexp-internal (rest slot) deserialized-objects))) + (when (slot-exists-p object (first slot)) + (setf (slot-value object (first slot)) + (deserialize-sexp-internal (rest slot) deserialized-objects)))) object))) (:struct (destructuring-bind (id &key class slots) (rest sexp) (let ((object (funcall (intern (concatenate 'string "MAKE-" (symbol-name class)) (symbol-package class))))) (setf (gethash id deserialized-objects) object) (dolist (slot slots) - (setf (slot-value object (first slot)) - (deserialize-sexp-internal (rest slot) deserialized-objects))) + (when (slot-exists-p object (first slot)) + (setf (slot-value object (first slot)) + (deserialize-sexp-internal (rest slot) deserialized-objects)))) object))) (:ref (gethash (rest sexp) deserialized-objects)))))