1. Leslie P. Polzer
  2. cl-prevalence

Commits

scaekenberghe  committed 1640b72

added code to deal with unbound slots when serializing (noted by anthony juckel)
and code to deal with missing slots when deserializing

  • Participants
  • Parent commits f912362
  • Branches default

Comments (0)

Files changed (1)

File src/serialization.lisp

View file
 	(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)
 	(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
 	  (: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)
                  (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)))))