Update of /project/elephant/cvsroot/elephant/src/elephant
In directory common-lisp:/tmp/cvs-serv12650/src/elephant
Modified Files:
classes.lisp classindex.lisp controller.lisp elephant.lisp
metaclasses.lisp migrate.lisp
Log Message:
Migration tests pass on BDB.
Only migrate ipclass failes under SQLite 3
(May be due to other current failures under SQLite 3)
Significant improvements in transaction stability,
stability with mutiple open stores, bdb processing speed,
and various bug fixes turned up by getting these tests
to pass.
--- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/02/19 04:53:00 1.1
+++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/02/21 19:40:03 1.2
@@ -174,7 +174,7 @@
(when (and (indexed class) (not from-oid))
(let ((class-index (find-class-index (class-of instance))))
(when class-index
- (with-transaction ()
+ (with-transaction (:store-controller (get-con class-index))
(setf (get-value oid class-index) instance)))))
))))
--- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/02/19 04:53:00 1.1
+++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/02/21 19:40:03 1.2
@@ -28,7 +28,7 @@
(defgeneric find-inverted-index (persistent-metaclass index-name &key null-on-fail)
(:documentation "This method finds an inverted index defined on
- the class described by persistent-metaclass."))
+ the class described by an instance of persistent-metaclass."))
(defgeneric enable-class-indexing (persistent-metaclass slot-names &rest rest)
(:documentation "Enable a class instance index for this object. It's
@@ -68,19 +68,20 @@
the dependant indices in synch. Only classes with derived indices need to
update on writes to non-indexed slots."
(let ((slot-name (slot-definition-name slot-def))
- (oid (oid instance)))
+ (oid (oid instance))
+ (con (get-con instance)))
(declare (type fixnum oid))
(if (no-indexing-needed? class instance slot-def oid)
- (with-transaction ()
- (persistent-slot-writer (get-con instance) new-value instance slot-name))
+ (with-transaction (:store-controller con)
+ (persistent-slot-writer con new-value instance slot-name))
(let ((class-idx (find-class-index class))
(*auto-commit* nil))
;; (format t "Indexing object: ~A oid: ~A~%" instance oid)
- (with-transaction ()
+ (with-transaction (:store-controller con)
;; NOTE: Quick and dirty hack to ensure consistency -- needs performance improvement
(when (get-value oid class-idx)
(remove-kv oid class-idx))
- (persistent-slot-writer (get-con instance) new-value instance slot-name)
+ (persistent-slot-writer con new-value instance slot-name)
(setf (get-value oid class-idx) instance))))))
@@ -164,7 +165,9 @@
(when (controller-class-root sc)
(map-btree (lambda (class-name index)
(declare (ignore index))
- (setf (%index-cache (find-class class-name)) nil))
+ (let ((class (find-class class-name :errorp nil)))
+ (when class
+ (setf (%index-cache class) nil))))
(controller-class-root sc))))
;; =============================
@@ -215,7 +218,7 @@
(remove-class-slot-index class name)
(with-transaction (:store-controller sc)
(remove-index class-idx name)))))
- ;; Drop the class instance index from the class root
+ ;; Drop the class instance index from the class root
(with-transaction (:store-controller sc)
(remove-kv (class-name class) (controller-class-root sc)))
(setf (%index-cache class) nil)
@@ -398,10 +401,9 @@
(when instances
(assert (consp instances))
(with-transaction (:store-controller sc)
- (let ((class-idx (find-class-index (class-of (first instances)))))
- (mapc (lambda (instance)
- (remove-kv (oid instance) class-idx))
- instances)))))
+ (mapc (lambda (instance)
+ (remove-kv (oid instance) (find-class-index (class-of instance))))
+ instances))))
;; =============================
;; CLASS / DB SYNCHRONIZATION
--- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/02/20 21:21:44 1.5
+++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/02/21 19:40:03 1.6
@@ -33,7 +33,7 @@
(defparameter *elephant-backends*
'((:bdb (:ele-bdb))
(:clsql (:ele-clsql))
- (:acache (:ele-acache))
+;; (:acache (:ele-acache))
)
"Entries have the form of (backend-type asdf-depends-list")
@@ -96,7 +96,12 @@
(satisfy-asdf-dependencies (second record))))
(defun satisfy-asdf-dependencies (dep-list)
- (mapc #'(lambda (dep) (asdf:operate 'asdf:load-op dep)) dep-list))
+ (mapc #'(lambda (dep)
+ ;; Only load the first time, after that it's the
+ ;; users fault if they edit source code
+ (unless (asdf::system-registered-p dep)
+ (asdf:operate 'asdf:load-op dep)))
+ dep-list))
;; ================================================
;;
@@ -173,7 +178,7 @@
(let ((obj (get-cache oid (instance-cache sc))))
(if obj obj
;; Should get cached since make-instance calls cache-instance
- (make-instance class-name :from-oid oid))))
+ (make-instance class-name :from-oid oid :sc sc))))
(defmethod flush-instance-cache ((sc store-controller))
"Reset the instance cache (flush object lookups). Useful
--- /project/elephant/cvsroot/elephant/src/elephant/elephant.lisp 2006/02/19 04:53:00 1.1
+++ /project/elephant/cvsroot/elephant/src/elephant/elephant.lisp 2006/02/21 19:40:03 1.2
@@ -46,7 +46,7 @@
#:primary #:key-form #:key-fn
#:btree-differ
- #:migrate
+ #:migrate #:*inhibit-slot-copy*
#:cursor #:secondary-cursor #:make-cursor
#:with-btree-cursor #:cursor-close #:cursor-init
--- /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/19 20:06:04 1.2
+++ /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/21 19:40:03 1.3
@@ -358,14 +358,20 @@
(make-persistent-slot-boundp name)))
slot-def)
-(defun persistent-slot-names (class)
+(defun persistent-slot-defs (class)
(let ((slot-definitions (class-slots class)))
- (loop for slot-definition in slot-definitions
- when (subtypep (type-of slot-definition) 'persistent-effective-slot-definition)
- collect (slot-definition-name slot-definition))))
+ (loop for slot-def in slot-definitions
+ when (subtypep (type-of slot-def) 'persistent-effective-slot-definition)
+ collect slot-def)))
-(defun transient-slot-names (class)
+(defun transient-slot-defs (class)
(let ((slot-definitions (class-slots class)))
- (loop for slot-definition in slot-definitions
- unless (persistent-p slot-definition)
- collect (slot-definition-name slot-definition))))
+ (loop for slot-def in slot-definitions
+ unless (persistent-p slot-def)
+ collect slot-def)))
+
+(defun persistent-slot-names (class)
+ (mapcar #'slot-definition-name (persistent-slot-defs class)))
+
+(defun transient-slot-names (class)
+ (mapcar #'slot-definition-name (transient-slot-defs class)))
\ No newline at end of file
--- /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2006/02/20 15:45:37 1.2
+++ /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2006/02/21 19:40:06 1.3
@@ -27,17 +27,28 @@
;; NOTES AND LIMITATIONS:
;; - Migrate currently will not handle circular list objects
;; - Migrate does not support arrays with nested persistent objects
+;;
+;;
+;; - Indexed classes only have their class index copied if you use the
+;; top level migration. Objects will be copied without slot data if you
+;; try to migrate an object outside of a store-to-store migration due to
+;; the class object belonging to one store or another
;; - 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...
+;; up the semantics, just add storage overhead 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...
+;; - Migration does not maintain OID equivalence so any datastructures which
+;; index into those will have to have a way to reconstruct themselves (better
+;; to keep the object references themselves rather than oids)
;;
;; CUSTOMIZE MIGRATION:
;; - To customize migration overload a version of migrate to specialize on
@@ -48,8 +59,9 @@
;; 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
+;; default persistent slot copying, bind the dynamic variable
+;; *inhibit-slot-writes* in your user method using
+;; (with-inhibited-slot-copy () ...) a convenience macro
;;
@@ -84,7 +96,9 @@
(let ((*migrating* t))
(declare (special *migrating*))
(reset-migrate-duplicate-detection)
- (call-next-method))))
+ (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
@@ -103,18 +117,56 @@
"Perform a wholesale repository migration from the root.
Also acts as a poor man's GC if you copy to another store
of the same type!"
+ ;; Indexed class slots can only be copied once the class metaobject is
+ ;; pointing at the new indices...but we know that class indices only contain
+ ;; indexed persistent objects which (see below) are not copied by default
+ ;; so we do the slot updates here
+ (map-btree (lambda (classname classidx)
+ ;; Class indexes should never be copied already
+ (assert (not (object-was-copied-p classidx)))
+ (let ((newcidx
+ (with-transaction (:store-controller dst)
+ (build-indexed-btree dst))))
+ ;; Add inverse indices to new main class index
+ (map-indices (lambda (name srciidx)
+ (with-transaction (:store-controller dst)
+ (add-index newcidx
+ :index-name name
+ :key-form (key-form srciidx)
+ :populate nil)))
+ classidx)
+ ;; Add the class index to the class root
+ (with-transaction (:store-controller dst)
+ (setf (get-value classname (controller-class-root dst)) newcidx))
+ ;; Update the class to point at all it's new objects in the new store
+ (setf (%index-cache (find-class classname)) newcidx)
+ ;; Migrate the indexes' objects
+ (copy-cindex-contents newcidx classidx)
+ ;; And remember the class index just incase it's indexed elswhere
+ ;; (and trips the assert above)
+ (register-copied-object classidx newcidx)))
+ (controller-class-root src))
+ ;; Copy all other reachable objects
(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)
+(defun copy-cindex-contents (new old)
+ (let ((sc (get-con new)))
+ (map-btree (lambda (oldoid oldinst)
+ (declare (ignore oldoid))
+ (let ((newinst (migrate sc oldinst)))
+ (with-transaction (:store-controller sc)
+ ;; This isn't redundant in most cases, but we may have
+ ;; indexed objects without slots and without a slot
+ ;; write the new index won't be updated in that case
+ (setf (get-value (oid newinst) new) newinst))))
+ old)))
+
+
;; PERSISTENT OBJECTS THAT AREN'T INDICES
(defvar *inhibit-slot-copy* nil)
@@ -132,24 +184,22 @@
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)
+ ;; 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"
+;; (let ((dstcidx (get-value (class-name class) (controller-class-root dst))))
+;; (when (and (indexed class) ;; indexed
+;; (not dstcidx) ;; hasn't been copied
+;; (%index-cache class)) ;; we have a valid reference
+;; (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)))
@@ -164,24 +214,30 @@
(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)))
+ "Copy the persistent object reference by making a new one and
+ potentially copy over the slot values as well"
+ (let* ((class (class-of src))
+ (dst (make-instance (class-of src) :sc dstsc)))
(register-copied-object src dst)
- (unless *inhibit-slot-copy*
+ (when (and (not *inhibit-slot-copy*)
+ (not (inhibit-indexed-slot-copy? dstsc class)))
(copy-persistent-slots dstsc (class-of src) src dst))
dst))
+(defun inhibit-indexed-slot-copy? (sc class)
+ (and (indexed class)
+ (not (equal (controller-spec sc)
+ (:dbcn-spc-pst (%index-cache class))))))
+
(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
+ "Copy only persistent slots from src to dst"
+ (loop for slot-def in (persistent-slot-defs 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))))))
+ (let ((value (migrate dstsc (slot-value-using-class class src slot-def))))
+ (with-transaction (:store-controller dstsc)
+ (setf (slot-value-using-class class dst slot-def) value))))))
;; MIGRATE INDICES (Override normal persistent copies)
@@ -190,8 +246,9 @@
"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)
+ (let ((newbtree (build-btree dst)))
+ (with-transaction (:store-controller dst :txn-nosync t)
+ (copy-btree-contents dst newbtree src))
(register-copied-object src newbtree)
newbtree)))
@@ -199,19 +256,19 @@
"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)))
+ (with-transaction (:store-controller dst :txn-nosync t)
+ (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))
+ src)
+ (register-copied-object src newbtree)
+ newbtree))))
(defmethod copy-btree-contents ((sc store-controller) dst src)
(map-btree (lambda (key value)
(let ((newval (migrate sc value)))
- (with-transaction (:store-controller sc :txn-nosync t)
- (setf (get-value key dst) newval))))
+ (setf (get-value key dst) newval)))
src))
