Update of /project/elephant/cvsroot/elephant/src/elephant
In directory common-lisp:/tmp/cvs-serv24854/src/elephant
Modified Files:
backend.lisp collections.lisp controller.lisp migrate.lisp
Log Message:
Migration implementation; indexed class migration is broken but all else passes basic tests
--- /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2006/02/19 20:06:04 1.3
+++ /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2006/02/20 15:45:37 1.4
@@ -36,6 +36,7 @@
#:persistent-slot-boundp
#:persistent-slot-makunbound
;; Controllers
+ #:store-controller
#:open-controller
#:close-controller
#:controller-spec
@@ -44,12 +45,15 @@
#:root #:spec #:class-root
#:flush-instance-cache
;; Collection generic functions
+ #:btree #:btree-index #:indexed-btree
#:build-indexed-btree #:build-btree #:existsp
+ #:map-indices
;; Serialization
#:deserialize #:serialize
#:deserialize-from-base64-string
#:serialize-to-base64-string
;; Cursor accessors
+ #:cursor
#:cursor-btree
#:cursor-oid
#:cursor-initialized-p
@@ -77,6 +81,7 @@
#:persistent-slot-boundp
#:persistent-slot-makunbound
;; Controllers
+ #:store-controller
#:open-controller
#:close-controller
#:controller-spec
@@ -85,12 +90,15 @@
#:root #:spec #:class-root
#:flush-instance-cache
;; Collection generic functions
+ #:btree #:btree-index #:indexed-btree
#:build-indexed-btree #:build-btree #:existsp
+ #:map-indices
;; Serialization
#:deserialize #:serialize
#:deserialize-from-base64-string
#:serialize-to-base64-string
;; Cursor accessors
+ #:cursor
#:cursor-btree
#:cursor-oid
#:cursor-initialized-p
--- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2006/02/19 04:53:00 1.1
+++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2006/02/20 15:45:37 1.2
@@ -324,13 +324,13 @@
(progn ,@body)
(cursor-close ,var))))
-(defun map-btree (fn bt)
+(defun map-btree (fn btree)
"Like maphash."
- (with-btree-cursor (curs bt)
+ (with-btree-cursor (curs btree)
(loop
(multiple-value-bind (more k v) (cursor-next curs)
(unless more (return nil))
- (funcall fn k v)))))
+ (funcall fn k v)))))
(defun dump-btree (bt)
(format t "DUMP ~A~%" bt)
--- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/02/19 20:06:04 1.3
+++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/02/20 15:45:37 1.4
@@ -102,12 +102,12 @@
(open-controller *store-controller* :recover recover
:recover-fatal recover-fatal :thread thread))
-(defun close-store ()
+(defun close-store (&optional sc)
"Conveniently close the store controller."
(declare (special *store-controller*))
- (if *store-controller*
+ (if (or sc *store-controller*)
(progn
- (close-controller *store-controller*)
+ (close-controller (or sc *store-controller*))
(setf *store-controller* nil))))
(defmacro with-open-store ((spec) &body body)
--- /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2006/02/19 04:53:00 1.1
+++ /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2006/02/20 15:45:37 1.2
@@ -2,8 +2,8 @@
;;;
;;; migrate.lisp -- Migrate between repositories
;;;
-;;; Initial version 8/26/2004 by Ben Lee
-;;; <blee(a)common-lisp.net>
+;;; New Version 2/19/2006 by Ian Eslick
+;;; <ieslick(a)common-lisp.net>
;;;
;;; part of
;;;
@@ -20,79 +20,233 @@
(in-package "ELEPHANT")
;;
-;; MULTI-STORE OPERATION API
+;; The generic function Migrate provides an interface to moving objects between
+;; repositories
+;;
+
+;; NOTES AND LIMITATIONS:
+;; - Migrate currently will not handle circular list objects
+;; - Migrate does not support arrays with nested persistent objects
+;; - Migrate assumes that after migration, indexed classes belong to the
+;; target store.
+;; - In general, migration is a one-time activity and afterwards (or after
+;; 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 cost storage 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...
;;
+;; CUSTOMIZE MIGRATION:
+;; - To customize migration overload a version of migrate to specialize on
+;; your specific persistent class type.
+;;
+;; (defmethod migrate ((dst store-controller) (src my-class)))
+;;
+;; In the body of this method you can call (call-next-method)
+;; to get a destination repository object with all the slots copied over
+;; to the target repository which you can then overwrite. To avoid the
+;; slot copying, bind the dynamic variable *inhibit-slot-writes* in your
+;; user method using (with-inhibited-slot-copy () ...) a convenience macro
+;;
+
(defgeneric migrate (dst src)
(:documentation
"Migrate an object from the src object, collection or controller
- to the dst controller"))
+ to the dst controller. Returns a copy of the object in the new
+ store so you can drop it into a parent object or the root of
+ the dst controller"))
-(defmethod migrate ((dst store-controller) (src t))
- (error "Cannot migrate object ~A of type ~A" dst (type-of dst)))
+;; 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 t))
+ "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)
+ (call-next-method))))
+
+(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
+
(defmethod migrate ((dst store-controller) (src store-controller))
"Perform a wholesale repository migration from the root.
- Also a poor man's GC!"
- (migrate-btree-contents (controller-root dst) (controller-root src))
- ;; NOTE: we have to migrate class indexes also and update the class objects.
- )
+ Also acts as a poor man's GC if you copy to another store
+ of the same type!"
+ (map-btree (lambda (key value)
+ (let ((newval (migrate dst value)))
+ (with-transaction (:store-controller dst :txn-nosync t)
+ (add-to-root key newval :store-controller dst))))
+ (controller-root src))
+ (map-btree (lambda (classname classidx)
+ (declare (ignore classidx))
+ (when (find-class classname nil)
+ (migrate dst (find-class classname))))
+ (controller-class-root src))
+ dst)
+
+;; PERSISTENT OBJECTS THAT AREN'T INDICES
+
+(defvar *inhibit-slot-copy* nil)
+
+(defmacro with-inhibited-slot-copy ((&key &allow-other-keys) &body body)
+ `(let ((*inhibit-slot-copy* t))
+ (declare (special *inhibit-slot-copy*)
+ (dynamic-extent *inhibit-slot-copy*))
+ ,@body))
+
+(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
+ in the caller to keep the new object from having it's slots copied"
+ (let ((class (class-of src)))
+ (migrate dst class)
+ ;; Copy or lookup persistent object
+ (if (object-was-copied-p src)
+ (retrieve-copied-object src)
+ (copy-persistent-object dst src))))
+
+(defmethod migrate ((dst store-controller) (class persistent-metaclass))
+ ;; Migrate classes with indices
+ (return-from migrate)
+ (unless (or (not (indexed class))
+ (equal (controller-spec dst)
+ (:dbcn-spc-pst (%index-cache class))))
+ (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*))
+;; (make-instance (class-of src)
+;; :sc dstsc
+;; :from-oid (gethash (oid src) *migrate-copied-oids*)))
+
+(defun copy-persistent-object (dstsc src)
+ (let ((dst (make-instance (class-of src) :sc dstsc)))
+ (register-copied-object src dst)
+ (unless *inhibit-slot-copy*
+ (copy-persistent-slots dstsc (class-of src) src dst))
+ dst))
+
+(defun copy-persistent-slots (dstsc class src dst)
+ "Copy all slots from src to dst - transient and persistent
+ so we maintain any active data"
+ (loop for slot-def in (class-slots class) do
+ (when (slot-boundp-using-class class src slot-def)
+ (setf (slot-value-using-class class dst slot-def)
+ (migrate dstsc (slot-value-using-class class src slot-def))))))
+
+
+;; MIGRATE INDICES (Override normal persistent copies)
(defmethod migrate ((dst store-controller) (src btree))
- "Copy a currently persistent object to a new repository."
- (let ((newbtree (build-btree dst)))
- newbtree))
+ "Copy an index and it's contents to the target repository"
+ (if (object-was-copied-p src)
+ (retrieve-copied-object src)
+ (let ((newbtree (build-btree dst)))
+ (copy-btree-contents dst newbtree src)
+ (register-copied-object src newbtree)
+ newbtree)))
+
+(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)
+ (let ((newbtree (build-indexed-btree dst)))
+ (copy-btree-contents dst newbtree src)
+ (map-indices (lambda (name srciidx)
+ (add-index newbtree :index-name name :key-form (key-form srciidx) :populate t))
+ newbtree)
+ (register-copied-object src newbtree)
+ newbtree)))
-(defun migrate-btree-contents (dst src)
+(defmethod copy-btree-contents ((sc store-controller) dst src)
(map-btree (lambda (key value)
- (setf (get-value key dst) value))
+ (let ((newval (migrate sc value)))
+ (with-transaction (:store-controller sc :txn-nosync t)
+ (setf (get-value key dst) newval))))
src))
-(defmethod migrate ((dst store-controller) (btree indexed-btree))
- "Copy indexes and then copy contents and update indices"
- (let ((newbtree (build-indexed-btree dst)))
- (map-indices (lambda (name idx)
- (add-index newbtree :index-name name :key-form (key-form idx) :populate nil))
- btree)
- (migrate-btree-contents newbtree btree)
- newbtree))
-
-;; NOTE: These functions should get rolled into migrate GF
-
-(defun copy-from-key (key src dst)
- "Move the object identified by key on the root in the src to the dst."
- (let ((v (get-from-root key :store-controller src)))
- (if v
- (add-to-root key v :store-controller dst)
- v)))
-
-;; I don't know if I need a "deeper" copy here or not....
-(defun my-copy-hash-table (ht)
- (let ((nht (make-hash-table)))
- (maphash
- #'(lambda (k v)
- (setf (gethash k nht) v))
- ht)
- nht))
-
-;; ;; This routine attempst to do a destructive migration
-;; ;; of the object to the new repository
-(defmethod migraten-pobj ((dst store-controller) obj copy-fn)
- "Migrate a persistent object and apply a binary (lambda (dst src) ...) function to the new object."
- ;; The simplest thing to do here is to make
- ;; an object of the new class;
- ;; we will make it the responsibility of the caller to
- ;; perform the copy on the slots --- or
- ;; we can force them to pass in this function.
- (if (typep obj 'persistent)
- (let ((nobj (make-instance (type-of obj) :sc dst)))
- (apply copy-fn (list nobj obj))
- nobj)
- (error (format "obj ~A is not a persistent object!~%" obj))
- )
- )
+
+;; 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 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!"
+ (cons (migrate dst (car src))
+ (migrate dst (cdr src))))
+
+(defmethod migrate ((dst store-controller) (src string))
+ "Strings are fine to copy as is"
+ src)
+
+(defmethod migrate ((dst store-controller) (src array))
+ "NOTE: We need to handle arrays that might contain persistent objects!"
+ (warn "Arrays with persistent objects will fail migration!")
+ src)
+
