[bknr-cvs] hans changed trunk/bknr/datastore/src/data/object.lisp
BKNR Commits
bknr at bknr.net
Tue Jul 29 08:42:50 UTC 2008
Revision: 3672
Author: hans
URL: http://bknr.net/trac/changeset/3672
Schema evolution aid: In order to make it possible to restore
snapshots from older schema when slots of a class have been deleted,
provide for a CONVERT-SLOT-VALUE-WHILE-RESTORING generic function that
can be defined to convert old slot values into the new object layout.
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-29 07:40:57 UTC (rev 3671)
+++ trunk/bknr/datastore/src/data/object.lisp 2008-07-29 08:42:50 UTC (rev 3672)
@@ -377,6 +377,12 @@
(find (symbol-name slot-name)
(mapcar #'slot-definition-name (class-slots class)) :key #'symbol-name :test #'equal)))
+(defgeneric convert-slot-value-while-restoring (object slot-name value)
+ (:documentation "Generic function to be called to convert a slot's
+ value from a previous snapshot layout. OBJECT is the object that is
+ being restored, SLOT-NAME is the name of the slot in the old schema,
+ VALUE is the value of the slot in the old schema."))
+
(defun find-slot-name-with-automatic-rename (class slot-name)
(if (find slot-name (class-slots class) :key #'slot-definition-name)
slot-name
@@ -390,6 +396,9 @@
(t
(error "can't find a slot in class ~A which matches the name ~A used in the store snapshot"
(class-name class) slot-name))))
+ (convert-values ()
+ :report "Convert slot values using CONVERT-SLOT-VALUE-WHILE-RESTORING"
+ (cons 'convert-slot-values slot-name))
(ignore-slot ()
:report "Ignore slot, discarding values found in the snapshot file"
nil))))
@@ -419,24 +428,32 @@
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
- (restart-case
- (let ((*current-object-slot* (list 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))
- (if (eq value 'unbound)
- (slot-makunbound object slot-name)
- (setf (slot-value object slot-name) value))))))
- (set-slot-nil ()
- :report "Set slot to NIL."
- (setf (slot-value object slot-name) nil))
- (make-slot-unbound ()
- :report "Make slot unbound."
- (slot-makunbound object slot-name)))
- (decode stream)))) ; read and ignore value
+ (let ((value (decode stream)))
+ (cond
+ ((consp slot-name)
+ (assert (eq 'convert-slot-values (car slot-name)))
+ (convert-slot-value-while-restoring object (cdr slot-name) value))
+ ((null slot-name)
+ ;; ignore value
+ )
+ (t
+ (restart-case
+ (let ((*current-object-slot* (list object slot-name))
+ (*current-slot-relaxed-p* (or (null object)
+ (store-object-relaxed-object-reference-p object slot-name))))
+ (when object
+ (let ((bknr.indices::*indices-remove-p* nil))
+ (if (eq value 'unbound)
+ (slot-makunbound object slot-name)
+ (if (slot-boundp object slot-name)
+ (convert-slot-value-while-restoring object slot-name value)
+ (setf (slot-value object slot-name) value))))))
+ (set-slot-nil ()
+ :report "Set slot to NIL."
+ (setf (slot-value object slot-name) nil))
+ (make-slot-unbound ()
+ :report "Make slot unbound."
+ (slot-makunbound object slot-name))))))))
(defun snapshot-read-object (stream layouts)
(declare (optimize (speed 3)))
@@ -496,23 +513,30 @@
(%decode-store-object stream)))
(defun %decode-store-object (stream)
- ;; This is actually called in two contexts, when a slot-value is to be filled with a reference to a store object
- ;; and when a list of store objects is read from the transaction log (%decode-list). In the former case, references
- ;; two deleted objects are accepted when the slot pointing to the object is marked as being a "relaxed-object-reference",
- ;; in the latter case, no such information is available. To ensure maximum restorability of transaction logs, object
- ;; references stored in lists are always considered to be relaxed references, which means that references to deleted
- ;; objects are restored as NIL. Applications must be prepared to cope with NIL entries in such object lists (usually
+ ;; This is actually called in two contexts, when a slot-value is to
+ ;; be filled with a reference to a store object and when a list of
+ ;; store objects is read from the transaction log (%decode-list).
+ ;; In the former case, references two deleted objects are accepted
+ ;; when the slot pointing to the object is marked as being a
+ ;; "relaxed-object-reference", in the latter case, no such
+ ;; information is available. To ensure maximum restorability of
+ ;; transaction logs, object references stored in lists are always
+ ;; considered to be relaxed references, which means that references
+ ;; to deleted objects are restored as NIL. Applications must be
+ ;; prepared to cope with NIL entries in such object lists (usually
;; lists in slots).
(let* ((id (%decode-integer stream))
(object (or (store-object-with-id id)
- (warn "internal inconsistency during restore: can't find store object ~A in loaded store" id)))
+ (warn "internal inconsistency during restore: can't find store object ~A in loaded store"
+ id)))
(container (first *current-object-slot*))
(slot-name (second *current-object-slot*)))
(cond (object object)
((or *current-slot-relaxed-p* (not container))
(if container
- (warn "Reference to inexistent object with id ~A in relaxed slot ~A of object with class ~A with ID ~A."
+ (warn "Reference to inexistent object with id ~A in relaxed slot ~A of object ~
+ with class ~A with ID ~A."
id slot-name (type-of container) (store-object-id container))
(warn "Reference to inexistent object with id ~A from unnamed container, returning NIL." id))
@@ -521,7 +545,8 @@
(setf (next-object-id (store-object-subsystem)) (1+ id)))
nil)
- (t (error "Reference to inexistent object with id ~A from slot ~A of object ~A with ID ~A." id slot-name (type-of container)
+ (t (error "Reference to inexistent object with id ~A from slot ~A of object ~A with ID ~A."
+ id slot-name (type-of container)
(if container (store-object-id container) "unknown object"))))))
(defmethod snapshot-subsystem ((store store) (subsystem store-object-subsystem))
More information about the Bknr-cvs
mailing list