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*)) ,@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)

+ +