[bknr-cvs] hans changed trunk/bknr/datastore/src/data/object.lisp

[BKNR Commits]

Revision: 3491
Author: hans
URL: http://bknr.net/trac/changeset/3491

Add option to ignore objects in a snapshot that are of now-nonexistant classes.

U   trunk/bknr/datastore/src/data/object.lisp

Modified: trunk/bknr/datastore/src/data/object.lisp
===================================================================
--- trunk/bknr/datastore/src/data/object.lisp	2008-07-17 14:11:47 UTC (rev 3490)
+++ trunk/bknr/datastore/src/data/object.lisp	2008-07-17 14:48:01 UTC (rev 3491)
@@ -353,15 +353,15 @@
     (%encode-integer (store-object-id object) stream)
     (%encode-set-slots slots object stream)))
 
-(defvar *class-rename-hash*)
-
 (defun find-class-with-interactive-renaming (class-name)
-  (loop until (find-class class-name nil)
+  (loop until (or (null class-name)
+                  (find-class class-name nil))
 	do (progn
-	     (format *query-io* "Class ~A not found, enter new class: " class-name)
+	     (format *query-io* "Class ~A not found, enter new class or enter NIL to ignore objects of this class: " class-name)
 	     (finish-output *query-io*)
 	     (setq class-name (read *query-io*))))
-  (setf (gethash class-name *class-rename-hash*) (find-class class-name)))
+  (and class-name
+       (find-class class-name)))
 
 (defun find-slot-name-with-interactive-rename (class slot-name)
   (loop until (find slot-name (class-slots class) :key #'slot-definition-name)
@@ -406,20 +406,24 @@
          (class-name (%decode-symbol stream))
          (nslots (%decode-integer stream))
 	 (class (find-class-with-interactive-renaming class-name))
-         (slots (find-class-slots-with-interactive-renaming class (loop
-								   repeat nslots
-								   collect (%decode-symbol stream)))))
+         (slot-names (loop repeat nslots collect (%decode-symbol stream)))
+         (slots (if class
+                    (find-class-slots-with-interactive-renaming class slot-names)
+                    slot-names)))
     (setf (gethash id layouts)
           (cons class slots))))
 
 (defun %read-slots (stream object slots)
+  "Read the OBJECT from STREAM.  The individual slots of the object
+are expected in the order of the list SLOTS.  If the OBJECT is NIL,
+the slots are read from the snapshot and ignored."
   (declare (optimize (speed 3)))
   (dolist (slot-name slots)
-    (if slot-name			; NIL for slots which are not restored because of schema changes
+    (if slot-name ; NIL for slots which are not restored because of schema changes
 	(restart-case
 	    (let ((*current-object-slot* (list object slot-name))
-		  (*current-slot-relaxed-p*
-		   (store-object-relaxed-object-reference-p object slot-name)))
+		  (*current-slot-relaxed-p* (or (null object)
+                                                (store-object-relaxed-object-reference-p object slot-name))))
 	      (let ((value (decode stream)))
 		(when object
 		  (let ((bknr.indices::*indices-remove-p* nil))
@@ -437,30 +441,25 @@
 (defun snapshot-read-object (stream layouts)
   (declare (optimize (speed 3)))
   (with-simple-restart (skip-object "Skip the object.")
-    (let ((layout-id (%decode-integer stream))
-	  (object-id (%decode-integer stream)))
-      #+nil (format t "id: ~A~%" object-id)
-      (destructuring-bind (class &rest slots) (gethash layout-id layouts)
-	(declare (ignore slots))
-	#+nil (format t "; class: ~A~%" class)
-	(let ((result (make-instance class :id object-id)))
-	  result)))))
+    (let* ((layout-id (%decode-integer stream))
+           (object-id (%decode-integer stream))
+           (class (first (gethash layout-id layouts))))
+      ;; If the class is NIL, it was not found in the currently
+      ;; running Lisp image and objects of this class will be ignored.
+      (when class
+        (make-instance class :id object-id)))))
 
 (defun snapshot-read-slots (stream layouts)
   (let* ((layout-id (%decode-integer stream))
 	 (object-id (%decode-integer stream))
 	 (object (store-object-with-id object-id)))
     (restart-case
-	(progn
-	  #+nil (format t "read-slots for object ~A, id ~A~%" object object-id)
-	  (unless object
-	    (error "READ-SLOTS form for unexistent object with ID ~A~%" object-id))
-	  (%read-slots stream object (cdr (gethash layout-id layouts))))
-	(skip-object-initialization ()
-	  :report "Skip object initialization.")
-	(delete-object ()
-	  :report "Delete the object."
-	  (delete-object object)))))
+	(%read-slots stream object (cdr (gethash layout-id layouts)))
+      (skip-object-initialization ()
+        :report "Skip object initialization.")
+      (delete-object ()
+        :report "Delete the object."
+        (delete-object object)))))
 
 (defmethod encode-object ((object store-object) stream)
   (if (object-destroyed-p object)
@@ -563,7 +562,6 @@
 	      (created-objects 0)
 	      (read-slots 0)
 	      (error t)
-              (*class-rename-hash* (make-hash-table))
               (*slot-name-map* nil))
 	  (unwind-protect
 	       (progn
@@ -584,8 +582,8 @@
 			(format t "unknown char ~A at offset ~A~%" char (file-position s)))
 		      (ecase char
 			((nil) (return))
-			(#\O (snapshot-read-object s class-layouts) (incf created-objects))
 			(#\L (snapshot-read-layout s class-layouts))
+			(#\O (snapshot-read-object s class-layouts) (incf created-objects))
 			(#\S (snapshot-read-slots s class-layouts) (incf read-slots))))))
 		 (map-store-objects #'initialize-transient-instance)
 		 (setf error nil))