[cl-prevalence-cvs] CVS update: cl-prevalence/src/serialization.lisp

[Sven Van Caekenberghe]

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)))))