[elephant-cvs] CVS elephant/tests
ieslick
ieslick at common-lisp.net
Mon Feb 20 15:45:38 UTC 2006
Update of /project/elephant/cvsroot/elephant/tests
In directory common-lisp:/tmp/cvs-serv24854/tests
Modified Files:
elephant-tests.lisp testmigration.lisp
Log Message:
Migration implementation; indexed class migration is broken but all else passes basic tests
--- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/19 17:25:53 1.15
+++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/20 15:45:38 1.16
@@ -129,12 +129,17 @@
(*test-spec-secondary* spec2))
(declare (special *test-spec-primary* *test-spec-secondary*))
(print (do-test 'remove-element))
- (print (do-test 'migrate1))
- (print (do-test 'migrate2))
- (print (do-test 'migrate3))
- (print (do-test 'migrate4))
- (print (do-test 'migrate5))))
+ (print (do-test 'migrate-basic))
+ (print (do-test 'migrate-btree))
+ (print (do-test 'migrate-idx-btree))
+ (print (do-test 'migrate-pclass))))
+;; (print (do-test 'migrate-ipclass))))
+(defun do-migration-test-spec (test spec1 spec2)
+ (let ((*test-spec-primary* spec1)
+ (*test-spec-secondary* spec2))
+ (declare (special *test-spec-primary* *test-spec-secondary*))
+ (print (do-test test))))
;;
--- /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/19 04:53:02 1.7
+++ /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/20 15:45:38 1.8
@@ -13,6 +13,14 @@
(in-package :ele-tests)
+;; TEST TODO:
+;; - inhibited slot copy & user overloading of migrate methodss
+;; - proper use of clearing the tracking of copies
+;; (oids not same over two copys of same object)
+;; - whole repository migration (write comparison method to sanity check)
+;; - transient slot migration is correct (online transfer of state to new repos)
+;; -
+
(deftest remove-element
(if (or (not (boundp '*test-spec-secondary*))
(null *test-spec-secondary*))
@@ -27,7 +35,8 @@
(equal (length a) (length ans)))))
t)
-(deftest migrate1
+;; Simple root element copy
+(deftest migrate-basic
(if (or (not (boundp '*test-spec-secondary*) )
(null *test-spec-secondary*))
(progn
@@ -41,10 +50,10 @@
(sc2 nil))
(unwind-protect
(progn
- (setf sc1 (open-store *test-spec-primary*))
- (setf sc2 (open-store *test-spec-secondary*))
+ (setf sc1 (open-store *test-spec-primary* :recover t))
+ (setf sc2 (open-store *test-spec-secondary* :recover t))
(add-to-root "x" "y" :store-controller sc1)
- (copy-from-key "x" sc1 sc2)
+ (migrate sc2 sc1)
(setf rv (equal (get-from-root "x" :store-controller sc1)
(get-from-root "x" :store-controller sc2))))
(progn
@@ -55,8 +64,8 @@
rv))
t)
-
-(deftest migrate2
+;; Simple test of a btree
+(deftest migrate-btree
(if (or (not (boundp '*test-spec-secondary*) )
(null *test-spec-secondary*))
(progn
@@ -70,7 +79,7 @@
(let
((sc1 (open-store *test-spec-primary*))
(sc2 (open-store *test-spec-secondary*)))
- (let ((ibt (build-btree sc1)))
+ (let ((ibt (make-btree sc1)))
(loop for i from 0 to 10
do
(setf (get-value i ibt) (* i i)))
@@ -81,8 +90,8 @@
(setq *auto-commit* *prev-commit*)))))
nil)
-
-(deftest migrate3
+;; Simple test of indexed btrees
+(deftest migrate-idx-btree
(if (or (not (boundp '*test-spec-secondary*) )
(null *test-spec-secondary*))
(progn
@@ -96,23 +105,21 @@
(let ((sc1 (open-store *test-spec-primary*))
(sc2 (open-store *test-spec-secondary*))
)
- (let* ((ibt (build-indexed-btree sc1)))
- (let (
- (index
+ (let* ((ibt (make-indexed-btree sc1)))
+ (let ((index
(add-index ibt :index-name 'crunch :key-form 'crunch
- :populate t))
- )
+ :populate t)))
(loop for i from 0 to 10
do
(setf (get-value i ibt) (* i i)))
(let* ((mig (migrate sc2 ibt))
- (nindex (gethash 'crunch (indices ibt))))
+ (nindex (get-index ibt 'crunch)))
(loop for i from 0 to 10
do
(if (not
(equal
(get-value i index)
- (get-value i nindex)
+ (get-value i nindex)
))
(progn
(format t "YIKES ~A ~%" i)
@@ -126,79 +133,72 @@
))
t)
-
-(deftest migrate4
+;; Simple test of persistent classes
+(deftest migrate-pclass
(if (or (not (boundp '*test-spec-secondary*) )
(null *test-spec-secondary*))
(progn
(format t "~%Single store mode: ignoring")
t)
- (finishes
- (let ((old-store *store-controller*)
- (*prev-commit* *auto-commit*)
- (*auto-commit* t)
- (rv nil))
- (unwind-protect
- (let* (
- (sc1 (open-store *test-spec-primary*))
- (sc2 (open-store *test-spec-secondary*))
- )
- (let* ((ibt (build-indexed-btree sc1)))
- (let (
- (index
- (add-index ibt :index-name 'crunch :key-form 'crunch
- :populate t))
- (x 0)
- )
- (loop for i from 0 to 10
- do
- (setf (get-value i ibt) (* i i)))
- )))
- (progn
- (setq *store-controller* old-store)
- (setq *auto-commit* *prev-commit*)))
- )))
+ (let ((*prev-commit* *auto-commit*))
+ (unwind-protect
+ (prog2
+ (setq *auto-commit* t)
+ (let (
+ (sc1 (open-store *test-spec-primary*))
+ (sc2 (open-store *test-spec-secondary*)))
+ (let* ((f1 (make-instance 'pfoo :sc sc1))
+ (f2 (make-instance 'pfoo :slot1 "this is a string" :sc sc1))
+ (b1 (make-instance 'pbar :slot2 "another string" :sc sc1))
+ )
+ (let ((fm1 (migrate sc2 f1))
+ (fm2 (migrate sc2 f2))
+ (bm1 (migrate sc2 b1)))
+ (and
+ (and (not (slot-boundp fm1 'slot1))
+ (not (slot-boundp f1 'slot1)))
+ (equal (slot1 fm2) (slot1 f2))
+ (equal (slot2 bm1) (slot2 b1)))
+ ))))
+ (setq *auto-commit* *prev-commit*))))
t)
-(deftest migrate5
+(defpclass ipfoo ()
+ ((slot1 :accessor slot1 :initarg :slot1 :index t)))
+
+;; Simple test of persistent classes with indexed slots
+(deftest migrate-ipclass
(if (or (not (boundp '*test-spec-secondary*) )
(null *test-spec-secondary*))
(progn
(format t "~%Single store mode: ignoring")
t)
(let ((*prev-commit* *auto-commit*))
- (prog2
- (setq *auto-commit* t)
- (let (
- (sc1 (open-store *test-spec-primary*))
- (sc2 (open-store *test-spec-secondary*)))
- (let* ((f1 (make-instance 'pfoo :sc sc1))
- (f2 (make-instance 'pfoo :slot1 "this is a string" :sc sc1))
- (b1 (make-instance 'pbar :slot2 "another string" :sc sc1))
- )
- (let ((fm1
- (migrate ;; (ele::migraten-pobj
- sc2 f1
- #'(lambda (dst src)
- (if (slot-boundp src 'slot1)
- (setf (slot1 dst) (slot1 src))))))
- (fm2
- (migrate ;; (ele::migraten-pobj
- sc2 f2
- #'(lambda (dst src)
- (if (slot-boundp src 'slot1)
- (setf (slot1 dst) (slot1 src))))))
- (bm1 (migrate ;; (ele::migraten-pobj
- sc2 b1
- #'(lambda (dst src)
- (if (slot-boundp src 'slot2)
- (setf (slot2 dst) (slot2 src))))))
- )
- (and
- (and (not (slot-boundp fm1 'slot1))
- (not (slot-boundp f1 'slot1)))
-;; (equal (slot1 fm2) (slot1 f2))
-;; (equal (slot2 bm1) (slot2 b1))
- ))))
- (setq *auto-commit* *prev-commit*))))
- t)
+ (unwind-protect
+ (prog2
+ (setq *auto-commit* t)
+ (let ((sc1 (open-store *test-spec-primary*))
+ (sc2 (open-store *test-spec-secondary*)))
+ ;; ensure class index is initialized in sc1
+ (find-class-index 'ipfoo :sc sc1)
+ (let* ((f1 (make-instance 'ipfoo :sc sc1))
+ (f2 (make-instance 'ipfoo :slot1 10))
+ (f3 (make-instance 'ipfoo :slot1 20)))
+ (format t "Made instances")
+ (let ((fm1 (migrate sc2 f1))
+ (fm2 (migrate sc2 f2))
+ (fm3 (migrate sc2 f3)))
+ (format t "Migrated instances")
+ (values
+ (and
+ (and (not (slot-boundp fm1 'slot1))
+ (not (slot-boundp f1 'slot1)))
+ (equal (slot1 fm2) (slot1 f2))
+ (equal (slot2 fm3) (slot2 f3)))
+ (length (get-instances-by-class 'ipfoo)))
+ ))))
+ (setq *auto-commit* *prev-commit*))))
+ t 2 )
+
+
+
More information about the Elephant-cvs
mailing list