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@common-lisp.net +;;; New Version 2/19/2006 by Ian Eslick +;;; ieslick@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) +