[elephant-cvs] CVS elephant/src/elephant
ieslick
ieslick at common-lisp.net
Sun Mar 11 05:45:17 UTC 2007
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*))
- , at 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*))
+ , at 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*
More information about the Elephant-cvs
mailing list