Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv24007/src/elephant

Modified Files: migrate.lisp package.lisp Log Message: Added support for maintaining oid-to-oid map in an external database; cleaned up tests and do-migration-tests to allow validation

--- /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2007/03/11 03:31:09 1.11 +++ /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2007/03/11 05:45:14 1.12 @@ -71,7 +71,6 @@ ;;

- (defgeneric migrate (dst src) (:documentation "Migrate an object from the src object, collection or controller @@ -79,47 +78,9 @@ store so you can drop it into a parent object or the root of the dst controller"))

-;; DEFAULT HANDLERS - -(defmethod migrate ((dst t) (src t)) - (error "Cannot migrate ~A of type ~A to destination of type ~A" src (type-of src) (type-of dst))) - -(defmethod migrate ((dst store-controller) (src t)) - "Default: standard objects are automatically migrated" - src) - -;; Avoiding Duplication Semantics - -(defvar *migrate-copied-oids* (make-hash-table)) -(defvar *migrating* nil) - -;; ERROR CHECKING - -(defmethod migrate :around ((dst store-controller) (src store-controller)) - "This method ensures that we wipe our duplication detection - around any top level call to migrate" - (if *migrating* - (call-next-method) - (let ((*migrating* t)) - (declare (special *migrating*)) - (reset-migrate-duplicate-detection) - (let ((result (call-next-method))) - (reset-migrate-duplicate-detection) - result)))) - -(defmethod migrate :before ((dst store-controller) (src persistent)) - "This provides some sanity checking that we aren't trying to copy - to the same controller. We also need to be careful about deadlocking - our transactions among the two gets/puts. Each leaf migration should - be in its own transaction to avoid too many write locks. " - (let ((dst-spec (controller-spec dst))) - (unless (object-was-copied-p src) - (typecase src - (store-controller (assert (not (equal dst-spec (controller-spec src))))) - (persistent (assert (not (equal dst-spec (dbcn-spc-pst src))))))))) - ;; -;; WHOLE STORE MIGRATION +;; MIGRATE ALL OBJECTS IN SRC STORE-CONTROLLER TO THE +;; (TYPICALLY FRESH) DST STORE-CONTROLLER ;;

(defmethod migrate ((dst store-controller) (src store-controller)) @@ -184,33 +145,44 @@ old)))

;; -;; Utilities for persistent objects +;; HANDLE DEFAULTS ;;

-(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))) +(defmethod migrate ((dst t) (src t)) + (error "Cannot migrate ~A of type ~A to destination of type ~A" src (type-of src) (type-of dst)))

-(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*))) +(defmethod migrate ((dst store-controller) (src t)) + "Default: standard objects are automatically migrated" + src)

-(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)) +;; +;; ERROR CHECKING +;;

-(defun retrieve-copied-object (src) - "Get a copied object from the oid map" - (gethash (oid src) *migrate-copied-oids*)) +(defmethod migrate :before ((dst store-controller) (src persistent)) + "This provides some sanity checking that we aren't trying to copy + to the same controller. We also need to be careful about deadlocking + our transactions among the two gets/puts. Each leaf migration should + be in its own transaction to avoid too many write locks. " + (let ((dst-spec (controller-spec dst))) + (unless (object-was-copied-p src) + (typecase src + (store-controller (assert (not (equal dst-spec (controller-spec src))))) + (persistent (assert (not (equal dst-spec (dbcn-spc-pst src)))))))))

-(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*)) - ,@body)) +(defmethod migrate :before ((dst store-controller) (src store-controller)) + "This method ensures that we reset duplicate object detection over the store-controller" + (initialize-migrate-duplicate-detection)) + +(defmethod migrate :after ((dst store-controller) (src store-controller)) + "This method ensures that we reset duplicate object detection over the store-controller" + (clear-migrate-duplicate-detection)) + +(defmethod migrate ((dst store-controller) (src standard-class)) + (error "Cannot migrate class objects (i.e. ~A)" src)) + +(defmethod migrate ((dst store-controller) (src function)) + (error "Cannot migrate function objects (i.e. ~A)" src))

;; ;; PERSISTENT OBJECTS @@ -226,7 +198,7 @@ in the caller to keep the new object from having it's slots copied" ;; Copy or lookup persistent object (if (object-was-copied-p src) - (retrieve-copied-object src) + (retrieve-copied-object dst src) (copy-persistent-object dst src)))

(defun copy-persistent-object (dstsc src) @@ -259,13 +231,23 @@ (setf (slot-value-using-class class dst slot-def) value))))))

;; +;; User utilities for persistent objects +;; + +(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*)) + ,@body)) + +;; ;; 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" (if (object-was-copied-p src) - (retrieve-copied-object src) + (retrieve-copied-object dst src) (let ((newbtree (build-btree dst))) (ensure-transaction (:store-controller dst :txn-nosync t) (copy-btree-contents dst newbtree src)) @@ -275,7 +257,7 @@ (defmethod migrate ((dst store-controller) (src indexed-btree)) "Also copy the inverse indices for indexed btrees" (if (object-was-copied-p src) - (retrieve-copied-object src) + (retrieve-copied-object dst src) (let ((newbtree (ensure-transaction (:store-controller dst :txn-nosync t) (build-indexed-btree dst)))) @@ -298,8 +280,7 @@ src))

;; -;; These functions handle standard objects that may contain nested indices or -;; user-defined persistent objects. +;; MIGRATE AGGREGATE LISP OBJECTS THAT MAY REFER TO OTHER PERSISTENT OBJECTS ;;

(defmethod migrate ((dst store-controller) (src standard-object)) @@ -309,10 +290,22 @@ 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)) + (let ((slotname (pop svs)) (value (pop svs))) - (setf (slot-value src name) (migrate dst value)))))) + (setf (slot-value src slotname) (migrate dst value))))) + src) +

+(defmethod migrate ((dst store-controller) (src structure-object)) + "Walks structure slot values and ensures that any persistent references + are written back into the slot pointint to the new store" + (let ((svs (struct-slots-and-values src))) + (loop for i from 0 below (/ (length svs) 2) do + (let ((slotname (pop svs)) + (value (pop svs))) + (setf (slot-value src slotname) + (migrate dst value))))) + src)

(defmethod migrate ((dst store-controller) (src cons)) "WARNING: This doesn't work for circular lists" @@ -336,7 +329,72 @@ src) src)

+;; +;; MAINTAIN CORRESPONDENCE BETWEEN OLD STORE POBJS and NEW STORE POBJS +;; + +(defvar *oid-hash* (make-hash-table)) +(defvar *oid-store* nil) +(defvar *oid-spec* nil) +(defvar *oid-btree* nil) + +(defun set-oid-spec (spec) + "Set to nil to perform oid mapping in memory, set to a valid spec to + perform the mapping on disk" + (setf *oid-spec* spec)) + +(defun initialize-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" + (if *oid-spec* + (progn + (setf *oid-store* (open-store *oid-spec* :recover t)) + (setf *oid-btree* (make-btree *oid-store*)) + (setf *oid-hash* nil)) + (progn + (setf *oid-hash* (make-hash-table)) + (setf *oid-btree* nil)))) + +(defun clear-migrate-duplicate-detection () + (when *oid-spec* + (setf *oid-btree* nil) + (close-store *oid-store*) + (setf *oid-store* nil)) + (when *oid-hash* + (setf *oid-hash* nil))) + +(defun object-was-copied-p (src) + "Test whether a source object has been copied" + (assert (subtypep (type-of src) 'persistent)) + (cond (*oid-btree* + (existsp (oid src) *oid-btree*)) + (*oid-hash* + (gethash (oid src) *oid-hash*)) + (t (warn "Test for persistent copy not inside top level call; returning nil") + nil))) + + +(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)))) + (when (or *oid-btree* *oid-hash*) + (if *oid-btree* + (setf (get-value (oid src) *oid-btree*) + (cons (oid dst) (type-of dst))) + (setf (gethash (oid src) *oid-hash*) dst))))

+(defun retrieve-copied-object (dst src) + "Get a copied object from the oid map" + (assert (subtypep (type-of dst) 'store-controller)) + (cond (*oid-btree* + (let ((record (get-value (oid src) *oid-btree*))) + (get-cached-instance dst (car record) (cdr record)))) + (*oid-hash* + (gethash (oid src) *oid-hash*)) + (t (error "Cannot retrieve an object from oid-to-oid map + when not inside top-level call")))) + +

--- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/03/06 04:15:27 1.22 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/03/11 05:45:14 1.23 @@ -64,7 +64,7 @@

#:struct-constructor

- #:migrate #:*inhibit-slot-copy* + #:migrate #:set-oid-spec #:*inhibit-slot-copy* #:add-symbol-conversion #:add-package-conversion #:*always-convert*