[elephant-cvs] CVS elephant/tests
ieslick
ieslick at common-lisp.net
Tue Feb 21 19:40:08 UTC 2006
Update of /project/elephant/cvsroot/elephant/tests
In directory common-lisp:/tmp/cvs-serv12650/tests
Modified Files:
elephant-tests.lisp testindexing.lisp testmigration.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/tests/elephant-tests.lisp 2006/02/20 15:45:38 1.16
+++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/21 19:40:08 1.17
@@ -80,7 +80,7 @@
'(:clsql (:postgresql "localhost.localdomain" "test" "postgres" "")))
(defvar *testsqlite3-spec*
- '(:clsql (:sqlite3 "sqlite3-test.db"))
+ '(:clsql (:sqlite3 "tests/sqlite3-test.db"))
"This is of the form '(filename &optional init-function),")
(defvar *testsqlite3-memory-spec*
@@ -132,8 +132,8 @@
(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))))
+ (print (do-test 'migrate-pclass))
+ (print (do-test 'migrate-ipclass))))
(defun do-migration-test-spec (test spec1 spec2)
(let ((*test-spec-primary* spec1)
--- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/19 04:53:02 1.5
+++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/21 19:40:08 1.6
@@ -30,8 +30,9 @@
;;(format t "Global vars:~%")
;;(format t "~%basic store: ~A ~A~%" *store-controller* (elephant::controller-spec *store-controller*))
;;(format t "auto-commit: ~A~%" *auto-commit*)
- (disable-class-indexing 'idx-one :errorp nil)
- (setf (find-class 'idx-one) nil)
+ (when (find-class 'idx-one nil)
+ (disable-class-indexing 'idx-one :errorp nil)
+ (setf (find-class 'idx-one) nil))
(defclass idx-one ()
((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t))
@@ -55,28 +56,33 @@
(deftest indexing-inherit
(progn
;; (format t "inherit store: ~A ~A~%" *store-controller* (controller-path *store-controller*))
- (disable-class-indexing 'idx-one :sc *store-controller* :errorp nil)
- (disable-class-indexing 'idx-two :sc *store-controller* :errorp nil)
- (setf (find-class 'idx-one) nil)
- (setf (find-class 'idx-two) nil)
- (defclass idx-one ()
+ (when (find-class 'idx-two nil)
+ (disable-class-indexing 'idx-two :sc *store-controller* :errorp nil)
+ (setf (find-class 'idx-two) nil))
+
+ (when (find-class 'idx-three nil)
+ (disable-class-indexing 'idx-three :sc *store-controller* :errorp nil)
+ (setf (find-class 'idx-three) nil))
+
+ (defclass idx-two ()
((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t)
(slot2 :initarg :slot2 :initform 2 :accessor slot2 :index t)
(slot3 :initarg :slot3 :initform 3 :accessor slot3)
(slot4 :initarg :slot4 :initform 4 :accessor slot4 :transient t))
(:metaclass persistent-metaclass))
- (defclass idx-two (idx-one)
+ (defclass idx-three (idx-two)
((slot2 :initarg :slot2 :initform 20 :accessor slot2)
(slot3 :initarg :slot3 :initform 30 :accessor slot3 :index t)
(slot4 :initarg :slot4 :initform 40 :accessor slot4 :index t))
(:metaclass persistent-metaclass))
+
(progn
(with-transaction ()
- (setq inst1 (make-instance 'idx-one :sc *store-controller*))
- (setq inst2 (make-instance 'idx-two :sc *store-controller*)))
+ (setq inst1 (make-instance 'idx-two :sc *store-controller*))
+ (setq inst2 (make-instance 'idx-three :sc *store-controller*)))
(values (slot1 inst1)
(slot2 inst1)
@@ -86,47 +92,48 @@
(slot2 inst2)
(slot3 inst2)
(slot4 inst2)
- (equal (elephant::indexing-record-slots (elephant::indexed-record (find-class 'idx-one)))
- '(slot1 slot2))
(equal (elephant::indexing-record-slots (elephant::indexed-record (find-class 'idx-two)))
+ '(slot1 slot2))
+ (equal (elephant::indexing-record-slots (elephant::indexed-record (find-class 'idx-three)))
'(slot1 slot3 slot4)))))
1 2 3 4 1 20 30 40 t t)
(deftest indexing-range
(progn
;; (format t "range store: ~A ~A~%" *store-controller* (controller-path *store-controller*))
- (disable-class-indexing 'idx-two :errorp nil)
- (disable-class-indexing 'idx-one :errorp nil)
- (setf (find-class 'idx-two) nil)
- (setf (find-class 'idx-one) nil)
+ (when (find-class 'idx-four nil)
+ (disable-class-indexing 'idx-four :errorp nil)
+ (setf (find-class 'idx-four) nil))
- (defclass idx-one ()
+ (defclass idx-four ()
((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t))
(:metaclass persistent-metaclass))
- (defun make-idx-one (val)
- (make-instance 'idx-one :slot1 val))
+ (defun make-idx-four (val)
+ (make-instance 'idx-four :slot1 val))
(with-transaction ()
- (mapc #'make-idx-one '(1 1 1 2 2 4 5 5 5 6 10)))
+ (mapc #'make-idx-four '(1 1 1 2 2 4 5 5 5 6 10)))
;; Range should get multiple & single keys inclusive of
;; start and end
- (values (equal (mapcar #'slot1 (get-instances-by-range 'idx-one 'slot1 2 6))
+ (values (equal (mapcar #'slot1 (get-instances-by-range 'idx-four 'slot1 2 6))
'(2 2 4 5 5 5 6)) ;; interior range
- (equal (mapcar #'slot1 (get-instances-by-range 'idx-one 'slot1 0 2))
+ (equal (mapcar #'slot1 (get-instances-by-range 'idx-four 'slot1 0 2))
'(1 1 1 2 2))
- (equal (mapcar #'slot1 (get-instances-by-range 'idx-one 'slot1 6 15))
+ (equal (mapcar #'slot1 (get-instances-by-range 'idx-four 'slot1 6 15))
'(6 10))))
t t t)
(deftest indexing-reconnect-db
(progn
- (disable-class-indexing 'idx-two :errorp nil)
- (setf (find-class 'idx-two) nil)
;; (format t "connect store: ~A ~A~%" *store-controller* (controller-path *store-controller*))
+
+ (when (find-class 'idx-five nil)
+ (disable-class-indexing 'idx-two :errorp nil)
+ (setf (find-class 'idx-two) nil))
- (defclass idx-two ()
+ (defclass idx-five ()
((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t)
(slot2 :initarg :slot2 :initform 2 :accessor slot2)
(slot3 :initarg :slot3 :initform 3 :accessor slot3 :index t))
@@ -136,13 +143,13 @@
(*default-indexed-class-synch-policy* :db))
(with-transaction ()
- (make-instance 'idx-two))
+ (make-instance 'idx-five))
;; Wipe out the class so it's not a redefinition
- (setf (find-class 'idx-two) nil)
+ (setf (find-class 'idx-five) nil)
;; Assume our db is out of synch with our class def
- (defclass idx-two ()
+ (defclass idx-five ()
((slot1 :initarg :slot1 :initform 1 :accessor slot1)
(slot2 :initarg :slot2 :initform 2 :accessor slot2 :index t)
(slot3 :initarg :slot3 :initform 3 :accessor slot3 :index t))
@@ -150,34 +157,37 @@
;; Add an instance of the new class
(with-transaction ()
- (make-instance 'idx-two))
+ (make-instance 'idx-five))
;; DB should dominate (if set as default)
- (values (length (get-instances-by-value 'idx-two 'slot3 3))
- (length (get-instances-by-value 'idx-two 'slot1 1))
- (signals-error (length (get-instances-by-value 'idx-two 'slot2 2))))))
+ (values (length (get-instances-by-value 'idx-five 'slot3 3))
+ (length (get-instances-by-value 'idx-five 'slot1 1))
+ (signals-error (length (get-instances-by-value 'idx-five 'slot2 2))))))
2 2 t)
(deftest indexing-change-class
(progn
- (disable-class-indexing 'idx-one :errorp nil)
- (disable-class-indexing 'idx-two :errorp nil)
- (setf (find-class 'idx-one) nil)
- (setf (find-class 'idx-two) nil)
- (defclass idx-one ()
+ (when (find-class 'idx-six nil)
+ (disable-class-indexing 'idx-six :errorp nil)
+ (setf (find-class 'idx-six) nil))
+ (when (find-class 'idx-seven nil)
+ (disable-class-indexing 'idx-seven :errorp nil)
+ (setf (find-class 'idx-seven) nil))
+
+ (defclass idx-six ()
((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t)
(slot2 :initarg :slot2 :initform 2 :accessor slot2 :index t))
(:metaclass persistent-metaclass))
- (defclass idx-two ()
+ (defclass idx-seven ()
((slot1 :initarg :slot1 :initform 10 :accessor slot1 :index nil)
(slot3 :initarg :slot3 :initform 30 :accessor slot3 :index t)
(slot4 :initarg :slot4 :initform 40 :accessor slot4 :index t))
(:metaclass persistent-metaclass))
- (defmethod update-instance-for-different-class :before ((old idx-one)
- (new idx-two)
+ (defmethod update-instance-for-different-class :before ((old idx-six)
+ (new idx-seven)
&key)
(setf (slot3 new) (slot2 old)))
@@ -185,8 +195,8 @@
(foo nil))
(declare (special *auto-commit*)
(dynamic-extent *auto-commit*))
- (setf foo (make-instance 'idx-one))
- (change-class foo 'idx-two)
+ (setf foo (make-instance 'idx-six))
+ (change-class foo 'idx-seven)
(values
;; shared data from original slot
@@ -197,12 +207,12 @@
(slot3 foo)
(slot4 foo)
;; verify proper indexing changes (none should lookup a value)
- (get-instances-by-class 'idx-one)
- (get-instances-by-value 'idx-one 'slot1 1)
- (get-instances-by-value 'idx-one 'slot2 2)
+ (get-instances-by-class 'idx-six)
+ (get-instances-by-value 'idx-six 'slot1 1)
+ (get-instances-by-value 'idx-six 'slot2 2)
;; new indexes
- (length (get-instances-by-class 'idx-two))
- (length (get-instances-by-value 'idx-two 'slot3 2))
+ (length (get-instances-by-class 'idx-seven))
+ (length (get-instances-by-value 'idx-seven 'slot3 2))
)))
1 t 2 40 nil nil nil 1 1)
--- /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/20 21:21:45 1.9
+++ /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/21 19:40:08 1.10
@@ -42,27 +42,19 @@
(progn
(format t "~%Single store mode: ignoring")
t)
- (let ((old-store *store-controller*)
- (*prev-commit* *auto-commit*)
- (*auto-commit* t)
- (rv nil)
- (sc1 nil)
- (sc2 nil))
+ (let* ((*store-controller*)
+ (*auto-commit* t)
+ (sc1 (open-store *test-spec-primary* :recover t))
+ (sc2 (open-store *test-spec-secondary* :recover t)))
(unwind-protect
(progn
- (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)
(migrate sc2 sc1)
- (setf rv (equal (get-from-root "x" :store-controller sc1)
- (get-from-root "x" :store-controller sc2))))
- (progn
- (when sc1 (close-store sc1))
- (when sc2 (close-store sc2))
- (setq *store-controller* old-store)
- (setq *auto-commit* *prev-commit*)))
- rv))
- t)
+ (equal (get-from-root "x" :store-controller sc1)
+ (get-from-root "x" :store-controller sc2)))
+ (close-store sc1)
+ (close-store sc2))))
+ t)
;; Simple test of a btree
(deftest migrate-btree
@@ -71,23 +63,21 @@
(progn
(format t "~%Single store mode: ignoring")
nil)
- (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 (make-btree sc1)))
- (loop for i from 0 to 10
- do
- (setf (get-value i ibt) (* i i)))
- (let ((mig (migrate sc2 ibt)))
- (btree-differ ibt mig))))
- (progn
- (setq *store-controller* old-store)
- (setq *auto-commit* *prev-commit*)))))
+ (let ((*store-controller* nil)
+ (*auto-commit* t)
+ (sc1 (open-store *test-spec-primary* :recover t))
+ (sc2 (open-store *test-spec-secondary* :recover t)))
+ (declare (special *store-controller* *auto-commit*))
+ (unwind-protect
+ (let ((ibt (make-btree sc1)))
+ (with-transaction (:store-controller sc1)
+ (loop for i from 0 to 10
+ do
+ (setf (get-value i ibt) (* i i))))
+ (let ((mig (migrate sc2 ibt)))
+ (btree-differ ibt mig)))
+ (close-store sc1)
+ (close-store sc2))))
nil)
;; Simple test of indexed btrees
@@ -97,40 +87,41 @@
(progn
(format t "~%Single store mode: ignoring")
t)
- (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 (make-indexed-btree sc1)))
- (let ((index
- (add-index ibt :index-name 'crunch :key-form 'crunch
- :populate t)))
- (loop for i from 0 to 10
- do
- (setf (get-value i ibt) (* i i)))
- (let* ((mig (migrate sc2 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)
- ))
- (progn
- (format t "YIKES ~A ~%" i)
- )))
- (setf rv (not (btree-differ ibt mig)))
- ))))
- (progn
- (setq *store-controller* old-store)
- (setq *auto-commit* *prev-commit*)))
- rv
- ))
+ (let ((old-store *store-controller*)
+ (*store-controller* nil)
+ (*prev-commit* *auto-commit*)
+ (*auto-commit* t)
+ (rv nil)
+ (sc1 (open-store *test-spec-primary* :recover t))
+ (sc2 (open-store *test-spec-secondary* :recover t)))
+ (declare (special *auto-commit*))
+ (unwind-protect
+ (let* ((ibt (make-indexed-btree sc1)))
+ (let ((index
+ (add-index ibt :index-name 'crunch :key-form 'crunch
+ :populate t)))
+ (with-transaction (:store-controller sc1)
+ (loop for i from 0 to 10
+ do
+ (setf (get-value i ibt) (* i i))))
+ (let* ((mig (migrate sc2 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)
+ ))
+ (progn
+ (format t "YIKES ~A ~%" i)
+ )))
+ (not (btree-differ ibt mig)))))
+ (progn
+ (setq *store-controller* old-store)
+ (setq *auto-commit* *prev-commit*)
+ (close-store sc1)
+ (close-store sc2)))))
t)
;; Simple test of persistent classes
@@ -140,27 +131,32 @@
(progn
(format t "~%Single store mode: ignoring")
t)
- (let ((*prev-commit* *auto-commit*))
+ (let ((*auto-commit* t)
+ (*store-controller* nil)
+ (sc1 (open-store *test-spec-primary* :recover t))
+ (sc2 (open-store *test-spec-secondary* :recover t)))
+ (declare (special *auto-commit* *store-controller*))
(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*))))
+ (progn
+ ;; Make instances
+ (let* ((f1 (with-transaction (:store-controller sc1)
+ (make-instance 'pfoo :sc sc1)))
+ (f2 (with-transaction (:store-controller sc1)
+ (make-instance 'pfoo :slot1 "this is a string" :sc sc1)))
+ (b1 (with-transaction (:store-controller sc1)
+ (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)))
+ )))
+ (close-store sc1)
+ (close-store sc2))))
t)
(defpclass ipfoo ()
@@ -168,37 +164,54 @@
;; Simple test of persistent classes with indexed slots
(deftest migrate-ipclass
- (if (or (not (boundp '*test-spec-secondary*) )
+ (if (or (not (boundp '*test-spec-secondary*))
(null *test-spec-secondary*))
(progn
- (format t "~%Single store mode: ignoring")
- t)
- (let ((*prev-commit* *auto-commit*))
- (unwind-protect
- (progn
- (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 )
+ (format t "~%Single store mode: ignoring ")
+ (values 3 1 1 1 1 10 20 ))
+ (progn
+;; (format t "Opening store~%")
+ (let ((*auto-commit* nil)
+ (sc2 (open-store *test-spec-secondary* :recover t))
+ (sc1 (open-store *test-spec-primary* :recover t)))
+ (declare (special *auto-commit*))
+ (unwind-protect
+ ;; ensure class index is initialized in sc1
+ (progn
+ (setf (elephant::%index-cache (find-class 'ipfoo)) nil)
+ (find-class-index 'ipfoo :sc sc1)
+;; (format t "Making objects~%")
+ (with-transaction (:store-controller sc1)
+ (drop-instances (get-instances-by-class 'ipfoo) :sc sc1)
+ (make-instance 'ipfoo :slot1 1 :sc sc1)
+ (make-instance 'ipfoo :slot1 10 :sc sc1)
+ (make-instance 'ipfoo :slot1 20 :sc sc1))
+;; (format t "Migrating~%")
+ (migrate sc2 sc1)
+ ;; Make sure our ipfoo class now points at a cache in sc2!
+ (assert (equal (elephant::controller-spec sc2)
+ (:dbcn-spc-pst (elephant::%index-cache (find-class 'ipfoo)))))
+;; (format t "Fetching~%")
+ (let ((fm1 (get-instances-by-value 'ipfoo 'slot1 1))
+ (fm2 (get-instances-by-value 'ipfoo 'slot1 10))
+ (fm3 (get-instances-by-value 'ipfoo 'slot1 20))
+ (all (get-instances-by-class 'ipfoo)))
+;; (format t "Clear & return~%")
+ (let ((insts (get-instances-by-class 'ipfoo)))
+ (with-transaction (:store-controller sc2)
+;; (format t "Dropping instances~%")
+ (drop-instances insts :sc sc2)))
+ (values
+ (length all)
+ (length fm1)
+ (length fm2)
+ (length fm3)
+ (slot1 (car fm1))
+ (slot1 (car fm2))
+ (slot1 (car fm3)))))
+ (close-store sc1)
+ (close-store sc2)))))
+ 3 1 1 1 1 10 20 )
More information about the Elephant-cvs
mailing list