[elephant-cvs] CVS elephant/src/elephant

ieslick ieslick at common-lisp.net
Mon Feb 20 15:45:38 UTC 2006


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




More information about the Elephant-cvs mailing list