[elephant-cvs] CVS elephant/src/elephant
ieslick
ieslick at common-lisp.net
Sun Mar 11 03:31:10 UTC 2007
Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv26571/src/elephant
Modified Files:
collections.lisp migrate.lisp
Log Message:
Added functionality and test for migrating persistent references inside lisp aggregates: array, list and hash tables
--- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/03/06 04:15:27 1.12
+++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/03/11 03:31:09 1.13
@@ -423,40 +423,40 @@
(dump-btree bt :print-fn print-fn :count count))
(defmethod btree-differ-p ((x btree) (y btree))
- (assert (eq (get-con x) (get-con y)))
+;; (assert (eq (get-con x) (get-con y)))
(ensure-transaction (:store-controller (get-con x))
- (let ((cx1 (make-cursor x))
- (cy1 (make-cursor y))
- (done nil)
- (rv nil)
- (mx nil)
- (kx nil)
- (vx nil)
- (my nil)
- (ky nil)
- (vy nil))
- (cursor-first cx1)
- (cursor-first cy1)
- (do ((i 0 (1+ i)))
- (done nil)
- (multiple-value-bind (m k v) (cursor-current cx1)
- (setf mx m)
- (setf kx k)
- (setf vx v))
- (multiple-value-bind (m k v) (cursor-current cy1)
- (setf my m)
- (setf ky k)
- (setf vy v))
- (if (not (and (equal mx my)
- (equal kx ky)
- (equal vx vy)))
- (setf rv (list mx my kx ky vx vy)))
- (setf done (and (not mx) (not mx))
- )
- (cursor-next cx1)
- (cursor-next cy1)
- )
- (cursor-close cx1)
- (cursor-close cy1)
- rv
- )))
+ (ensure-transaction (:store-controller (get-con y))
+ (let ((cx1 (make-cursor x))
+ (cy1 (make-cursor y))
+ (done nil)
+ (rv nil)
+ (mx nil)
+ (kx nil)
+ (vx nil)
+ (my nil)
+ (ky nil)
+ (vy nil))
+ (cursor-first cx1)
+ (cursor-first cy1)
+ (do ((i 0 (1+ i)))
+ (done nil)
+ (multiple-value-bind (m k v) (cursor-current cx1)
+ (setf mx m)
+ (setf kx k)
+ (setf vx v))
+ (multiple-value-bind (m k v) (cursor-current cy1)
+ (setf my m)
+ (setf ky k)
+ (setf vy v))
+ (if (not (and (equal mx my)
+ (equal kx ky)
+ (equal vx vy)))
+ (setf rv (list mx my kx ky vx vy)))
+ (setf done (and (not mx) (not mx)))
+ (cursor-next cx1)
+ (cursor-next cy1)
+ )
+ (cursor-close cx1)
+ (cursor-close cy1)
+ rv
+ ))))
--- /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2007/03/09 00:44:35 1.10
+++ /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2007/03/11 03:31:09 1.11
@@ -26,8 +26,6 @@
;; LIMITATIONS:
;; - Migrate currently will not handle circular list objects
-;; - Migrate does not support arrays or standard objects with nested persistent objects
-;; - There are potential problems with graphs and other deep structures
;;
;; - Indexed classes only have their class index copied if you use the
;; top level migration. Objects will be copied without slot data if you
@@ -41,19 +39,18 @@
;; a validation test) the source store should be closed. Any failures
;; in migration should then be easy to catch.
;;
-;; - Each call to migration will be good about keeping track of already
-;; copied objects to avoid duplication. Duplication _shouldn't_ screw
-;; up the semantics, just add storage overhead but is to be avoided.
-;; However this information is not saved between calls and there's no
-;; other way to do comparisons between objects across stores (different
-;; oid namespaces) so user beware of the pitfalls of partial migrations...
-;;
;; - Migrate keeps a memory-resident hash of all persistent objects;
;; this is not as bad as it sounds as an object is only an oid reference
;; and a pointer to the store controller it belongs to. However, you
;; may eventually run out of heap space for very large DB's. We can use
;; the old DB to store the mappings if this becomes a problem.
;;
+;; - Each top-level call to migration will be good about keeping track
+;; of already copied persistent objects. However the hash is not
+;; saved between calls and there's no other way to do comparisons
+;; between objects across stores (different oid namespaces) so user
+;; beware of the pitfalls of partial migrations...
+;;
;; - Migration does not maintain OID equivalence so any datastructures which
;; index into those will have to have a way to reconstruct themselves (better
;; to keep the object references themselves rather than oids in general)
@@ -69,7 +66,7 @@
;; to get a destination repository object with all the slots copied over
;; to the target repository which you can then overwrite. To avoid the
;; default persistent slot copying, bind the dynamic variable
-;; *inhibit-slot-writes* in your user method using
+;; *inhibit-slot-copy* in your user method using
;; (with-inhibited-slot-copy () ...), a convenience macro.
;;
@@ -121,7 +118,9 @@
(store-controller (assert (not (equal dst-spec (controller-spec src)))))
(persistent (assert (not (equal dst-spec (dbcn-spc-pst src)))))))))
+;;
;; WHOLE STORE MIGRATION
+;;
(defmethod migrate ((dst store-controller) (src store-controller))
"Perform a wholesale repository migration from the root.
@@ -184,20 +183,43 @@
(setf (get-value (oid newinst) new) newinst))))
old)))
+;;
+;; Utilities for persistent objects
+;;
-;; PERSISTENT OBJECTS THAT AREN'T INDICES
+(defun reset-migrate-duplicate-detection ()
+ "Reset oid map so that all references to a given object
+ in the source only point to one copy in the target"
+ (setf *migrate-copied-oids* (make-hash-table)))
-(defvar *inhibit-slot-copy* nil)
+(defun object-was-copied-p (src)
+ "Test whether a source object has been copied"
+ (and (subtypep (type-of src) 'persistent)
+ (gethash (oid src) *migrate-copied-oids*)))
+
+(defun register-copied-object (src dst)
+ "When copying a source object, store it in the oid map"
+ (assert (not (equal (dbcn-spc-pst src) (dbcn-spc-pst dst))))
+ (setf (gethash (oid src) *migrate-copied-oids*) dst))
+
+(defun retrieve-copied-object (src)
+ "Get a copied object from the oid map"
+ (gethash (oid src) *migrate-copied-oids*))
(defmacro with-inhibited-slot-copy ((&key &allow-other-keys) &body body)
+ "A user macro to support special slot handling in persistent objects"
`(let ((*inhibit-slot-copy* t))
- (declare (special *inhibit-slot-copy*)
- (dynamic-extent *inhibit-slot-copy*))
+ (declare (special *inhibit-slot-copy*))
, at body))
+;;
+;; PERSISTENT OBJECTS
+;;
+
+(defvar *inhibit-slot-copy* nil)
+
(defmethod migrate ((dst store-controller) (src persistent))
"Migrate a persistent object and apply a binary (lambda (dst src) ...)
-
function to the new object. Users can override migrate by creating
a function that calls the default copy and then does stuff with the
slot values. A dynamic variable: *inhibit-slot-copy* can be bound
@@ -207,58 +229,38 @@
(retrieve-copied-object src)
(copy-persistent-object dst src)))
-;; (defmethod migrate ((dst store-controller) (class persistent-metaclass))
-;; "Migrate classes with indices"
-;; (let ((dstcidx (get-value (class-name class) (controller-class-root dst))))
-;; (when (and (indexed class) ;; indexed
-;; (not dstcidx) ;; hasn't been copied
-;; (%index-cache class)) ;; we have a valid reference
-;; (format t "Migrating class~A~%" (class-name class))
-;; (let ((new-cidx (migrate dst (%index-cache class)
-;; (setf (get-value (class-name class) (controller-class-root dst)) new-cidx)
-;; (setf (%index-cache class) new-cidx)))
-;; class)
-
-(defun reset-migrate-duplicate-detection ()
- (setf *migrate-copied-oids* (make-hash-table)))
-
-(defun object-was-copied-p (src)
- (and (subtypep (type-of src) 'persistent)
- (gethash (oid src) *migrate-copied-oids*)))
-
-(defun register-copied-object (src dst)
- (assert (not (equal (dbcn-spc-pst src) (dbcn-spc-pst dst))))
- (setf (gethash (oid src) *migrate-copied-oids*) dst))
-
-(defun retrieve-copied-object (src)
- (gethash (oid src) *migrate-copied-oids*))
-
(defun copy-persistent-object (dstsc src)
"Copy the persistent object reference by making a new one and
potentially copy over the slot values as well"
(let* ((class (class-of src))
(dst (make-instance (class-of src) :sc dstsc)))
(register-copied-object src dst)
- (when (and (not *inhibit-slot-copy*)
- (not (inhibit-indexed-slot-copy? dstsc class)))
- (copy-persistent-slots dstsc (class-of src) src dst))
+ (unless (inhibit-indexed-slot-copy? dstsc class)
+ (copy-persistent-slots dstsc dst (class-of src) src))
dst))
(defun inhibit-indexed-slot-copy? (sc class)
- (and (indexed class)
- (not (equal (controller-spec sc)
- (dbcn-spc-pst (%index-cache class))))))
+ "Make sure that we don't copy slots if the user inhibits
+ or if the class is indexed and has not yet migrated to
+ the new store - the indexing copy will do this."
+ (or *inhibit-slot-copy*
+ (and (indexed class)
+ (not (equal (controller-spec sc)
+ (dbcn-spc-pst (%index-cache class)))))))
-(defun copy-persistent-slots (dstsc class src dst)
+(defun copy-persistent-slots (dstsc dst class src)
"Copy only persistent slots from src to dst"
(ensure-transaction (:store-controller dstsc)
(loop for slot-def in (persistent-slot-defs class) do
(when (slot-boundp-using-class class src slot-def)
+;; (format t "Slotname: ~A value: ~A~%" (elephant::slot-definition-name slot-def)
+;; (slot-value-using-class class src slot-def))
(let ((value (migrate dstsc (slot-value-using-class class src slot-def))))
(setf (slot-value-using-class class dst slot-def) value))))))
-
-;; MIGRATE INDICES (Override normal persistent copies)
+;;
+;; MIGRATE BTREE INDICES (override default persistent behavior)
+;;
(defmethod migrate ((dst store-controller) (src btree))
"Copy an index and it's contents to the target repository"
@@ -295,40 +297,46 @@
(setf (get-value newkey dst) newval)))
src))
+;;
+;; These functions handle standard objects that may contain nested indices or
+;; user-defined persistent objects.
+;;
-;; SUPPORT LISP COLLECTIONS TO HANDLE NESTED PERSISTENT OBJECTS
-;; CLEANLY
-
-;; If we don't do this, then a nested persistent object may be
-;; of the source store's class and fail to copy slots on a write
-;; and we'll silently lose data...
+(defmethod migrate ((dst store-controller) (src standard-object))
+ "If we have persistent objects that are unindexed and ONLY stored in
+ a standard object slot that is referenced from the root, then it
+ will only be copied by recursing through the slot substructure just
+ as the serializer will, but copying any persistent objects found"
+ (let ((svs (slots-and-values src)))
+ (loop for i from 0 below (/ (length svs) 2) do
+ (let ((name (pop svs))
+ (value (pop svs)))
+ (setf (slot-value src name) (migrate dst value))))))
-(defmethod migrate ((dst store-controller) (src hash-table))
- "Copy the hash elements one at a time"
- (let ((newhash (make-hash-table
- :test (hash-table-test src)
- :size (hash-table-size src)
- :rehash-size (hash-table-rehash-size src)
- :rehash-threshold (hash-table-rehash-threshold src))))
- (maphash (lambda (key value)
- (setf (gethash key newhash)
- (migrate dst value)))
- src)))
(defmethod migrate ((dst store-controller) (src cons))
- "WARNING: This assumes a standard list or tree-of-lists, but doesn't
- work for circular lists!"
+ "WARNING: This doesn't work for circular lists"
(cons (migrate dst (car src))
(migrate dst (cdr src))))
-(defmethod migrate ((dst store-controller) (src string))
- "Strings are fine to copy as is"
+(defmethod migrate ((dst store-controller) (src array))
+ "We only need to handle arrays of type 't' that point to other objects;
+ fixnum, float, etc arrays don't need to be copied"
+ (loop for i fixnum from 0 below (array-total-size src) do
+ (let ((value (row-major-aref src i)))
+ (setf (row-major-aref src i)
+ (migrate dst value))))
src)
-(defmethod migrate ((dst store-controller) (src array))
- "NOTE: We need to handle arrays that might contain persistent objects!"
- (warn "Arrays containing persistent objects will fail migration!")
+(defmethod migrate ((dst store-controller) (src hash-table))
+ "Migrate each hash element as the types are non-uniform"
+ (maphash (lambda (key value)
+ (setf (gethash key src)
+ (migrate dst value)))
+ src)
src)
+
+
More information about the Elephant-cvs
mailing list