[elephant-cvs] CVS elephant/tests
ieslick
ieslick at common-lisp.net
Fri Feb 10 01:39:13 UTC 2006
Update of /project/elephant/cvsroot/elephant/tests
In directory common-lisp:/tmp/cvs-serv5850/tests
Modified Files:
elephant-tests.lisp testindexing.lisp
Log Message:
Added :index vs. :indexed slot option
Improved tests and added some more
Some minor cleanup
--- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/07 23:23:51 1.10
+++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/10 01:39:13 1.11
@@ -122,16 +122,19 @@
(setq *old-store* *store-controller*)
(unwind-protect
(progn
- (open-store *testdb-path*)
- (print (do-test 'indexing-basic))
- (print (do-test 'indexing-inherit))
- (print (do-test 'indexing-range))
- (print (do-test 'indexing-reconnect-db))
- (print (do-test 'indexing-change-class))
- (print (do-test 'indexing-redef-class))
- (print (do-test 'indexing-explicit-changes))
- (print (do-test 'indexing-timing))
- (close-store))
+ (let ((*auto-commit* nil))
+ (declare (special *auto-commit*)
+ (dynamic-extent *auto-commit*))
+ (open-store *testdb-path*)
+ (print (do-test 'indexing-basic))
+ (print (do-test 'indexing-inherit))
+ (print (do-test 'indexing-range))
+ (print (do-test 'indexing-reconnect-db))
+ (print (do-test 'indexing-change-class))
+ (print (do-test 'indexing-redef-class))
+ (print (do-test 'indexing-explicit-changes))
+ (print (do-test 'indexing-timing))
+ (close-store)))
(setq *store-controller* *old-store*)))
(defun do-crazy-pg-tests()
@@ -161,6 +164,8 @@
(when spec
(with-open-store (spec)
(let ((*auto-commit* nil))
+ (declare (special *auto-commit*)
+ (dynamic-extent *auto-commit*))
(do-tests)))))
(defun find-slot-def (class-name slot-name)
--- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/08 03:23:12 1.3
+++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/10 01:39:13 1.4
@@ -30,11 +30,11 @@
(setf (find-class 'idx-one) nil)
(defclass idx-one ()
- ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :indexed t))
+ ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t))
(:metaclass persistent-metaclass))
(progn
- (with-transaction ()
+ (with-transaction (:store-controller *store-controller*)
(setq inst1 (make-instance 'idx-one :slot1 1 :sc *store-controller*))
(setq inst2 (make-instance 'idx-one :slot1 1 :sc *store-controller*))
(setq inst3 (make-instance 'idx-one :slot1 3 :sc *store-controller*)))
@@ -57,51 +57,64 @@
(setf (find-class 'idx-two) nil)
(defclass idx-one ()
- ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :indexed t)
- (slot2 :initarg :slot2 :initform 2 :accessor slot2 :indexed t)
+ ((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)
((slot2 :initarg :slot2 :initform 20 :accessor slot2)
- (slot3 :initarg :slot3 :initform 30 :accessor slot3 :indexed t)
- (slot4 :initarg :slot4 :initform 40 :accessor slot4 :indexed t))
+ (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-two :sc *store-controller*)))
+ (setq inst1 (make-instance 'idx-one :sc *store-controller*))
+ (setq inst2 (make-instance 'idx-two :sc *store-controller*)))
(values (slot1 inst1)
(slot2 inst1)
(slot3 inst1)
(slot4 inst1)
+ (slot1 inst2)
+ (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 slot3 slot4)))))
- 1 20 30 40 t)
+ 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-one :sc *store-controller* :errorp nil)
+ (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)
(defclass idx-one ()
- ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :indexed t))
+ ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t))
(:metaclass persistent-metaclass))
(defun make-idx-one (val)
- (make-instance 'idx-one :slot1 val :sc *store-controller*))
+ (make-instance 'idx-one :slot1 val))
(with-transaction ()
(mapc #'make-idx-one '(1 1 1 2 2 4 5 5 5 6 10)))
;; Range should get multiple & single keys inclusive of
;; start and end
- (let ((list (mapcar #'slot1 (get-instances-by-range 'idx-one 'slot1 2 6))))
- (equal list '(2 2 4 5 5 5 6))))
- t)
+ (values (equal (mapcar #'slot1 (get-instances-by-range 'idx-one 'slot1 2 6))
+ '(2 2 4 5 5 5 6)) ;; interior range
+ (equal (mapcar #'slot1 (get-instances-by-range 'idx-one 'slot1 0 2))
+ '(1 1 1 2 2))
+ (equal (mapcar #'slot1 (get-instances-by-range 'idx-one 'slot1 6 15))
+ '(6 10))))
+ t t t)
(deftest indexing-reconnect-db
(progn
@@ -110,9 +123,9 @@
;; (format t "connect store: ~A ~A~%" *store-controller* (controller-path *store-controller*))
(defclass idx-two ()
- ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :indexed t)
+ ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t)
(slot2 :initarg :slot2 :initform 2 :accessor slot2)
- (slot3 :initarg :slot3 :initform 3 :accessor slot3 :indexed t))
+ (slot3 :initarg :slot3 :initform 3 :accessor slot3 :index t))
(:metaclass persistent-metaclass))
(let ((*old-default* *default-indexed-class-synch-policy*)
@@ -127,8 +140,8 @@
;; Assume our db is out of synch with our class def
(defclass idx-two ()
((slot1 :initarg :slot1 :initform 1 :accessor slot1)
- (slot2 :initarg :slot2 :initform 2 :accessor slot2 :indexed t)
- (slot3 :initarg :slot3 :initform 3 :accessor slot3 :indexed t))
+ (slot2 :initarg :slot2 :initform 2 :accessor slot2 :index t)
+ (slot3 :initarg :slot3 :initform 3 :accessor slot3 :index t))
(:metaclass persistent-metaclass))
;; Add an instance of the new class
@@ -142,8 +155,52 @@
2 2 t)
(deftest indexing-change-class
- nil
- nil)
+ (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 ()
+ ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t)
+ (slot2 :initarg :slot2 :initform 2 :accessor slot2 :index t))
+ (:metaclass persistent-metaclass))
+
+ (defclass idx-two ()
+ ((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)
+ &key)
+ (setf (slot3 new) (slot2 old)))
+
+ (let ((*auto-commit* t)
+ (foo nil))
+ (declare (special *auto-commit*)
+ (dynamic-extent *auto-commit*))
+ (setf foo (make-instance 'idx-one))
+ (change-class foo 'idx-two)
+
+ (values
+ ;; shared data from original slot
+ (slot1 foo)
+ ;; verify old instance access fails
+ (signals-error (slot2 foo))
+ ;; verify new instance is there
+ (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)
+ ;; new indexes
+ (length (get-instances-by-class 'idx-two))
+ (length (get-instances-by-value 'idx-two 'slot3 2))
+ )))
+ 1 t 2 40 nil nil nil 1 1)
(deftest indexing-redef-class
nil
@@ -156,14 +213,14 @@
;; create 10k objects, write each object's slots
(defclass stress-normal ()
- ((stress1 :accessor stress1 :initarg :stress1 :initform nil :indexed nil)
- (stress2 :accessor stress2 :initarg :stress2 :initform nil :indexed nil))
+ ((stress1 :accessor stress1 :initarg :stress1 :initform nil :index nil)
+ (stress2 :accessor stress2 :initarg :stress2 :initform nil :index nil))
(:metaclass persistent-metaclass))
(defclass stress-index ()
- ((stress1 :accessor stress1 :initarg :stress1 :initform nil :indexed t)
- (stress2 :accessor stress2 :initarg :stress2 :initform 2 :indexed t)
- (stress3 :accessor stress3 :initarg :stress3 :initform 3 :indexed nil))
+ ((stress1 :accessor stress1 :initarg :stress1 :initform nil :index t)
+ (stress2 :accessor stress2 :initarg :stress2 :initform 2 :index t)
+ (stress3 :accessor stress3 :initarg :stress3 :initform 3 :index nil))
(:metaclass persistent-metaclass))
(defvar normal-index nil)
@@ -207,32 +264,43 @@
(deftest indexing-timing
(progn
-
- (let ((insts (get-instances-by-class 'stress-index)))
+ (let ((insts (get-instances-by-class 'stress-index))
+ (start nil)
+ (end nil)
+ (normal-time 0)
+ (index-time 0))
(when insts
(drop-instances insts)))
- (format t "~%Stress test normal setup time (~A):~%" *stress-count*)
+;; (format t "~%Stress test normal setup time (~A):~%" *stress-count*)
(with-transaction ()
- (time (normal-stress-setup *stress-count* 'stress-normal :stress2 10)))
+ (normal-stress-setup *stress-count* 'stress-normal :stress2 10)
+ )
- (format t "~%Stress test indexed setup time (~A):~%" *stress-count*)
+;; (format t "~%Stress test indexed setup time (~A):~%" *stress-count*)
(with-transaction ()
- (time (indexed-stress-setup *stress-count* 'stress-index :stress2 10)))
+ (indexed-stress-setup *stress-count* 'stress-index :stress2 10)
+ )
- (format t "~%Stress test normal lookup time (~A):~%" *range-size*)
- (time
- (dotimes (i *range-size*)
- (declare (ignore i))
- (normal-range-lookup *stress-count* *range-size*)))
+;; (format t "~%Stress test normal lookup time (~A):~%" *range-size*)
+ (setf start (get-internal-run-time))
+ (dotimes (i *range-size*)
+ (declare (ignore i))
+ (normal-range-lookup *stress-count* *range-size*))
+ (setf end (get-internal-run-time))
+ (setf normal-time (/ (- end start 0.0) internal-time-units-per-second))
- (format t "~%Stress test indexed lookup time (~A):~%" *range-size*)
- (prof:with-profiling (:type :time)
- (time
+;; (format t "~%Stress test indexed lookup time (~A):~%" *range-size*)
+ (setf start (get-internal-run-time))
(dotimes (i *range-size*)
(declare (ignore i))
- (indexed-range-lookup 'stress-index *stress-count* *range-size*))))
- t)
+ (indexed-range-lookup 'stress-index *stress-count* *range-size*))
+ (setf end (get-internal-run-time))
+ (setf index-time (/ (- end start 0.0) internal-time-units-per-second))
+
+ (format t "~%Ranged get of ~A/~A objects = Linear: ~A sec Indexed: ~A sec~%"
+ *range-size* *stress-count* normal-time index-time)
+ (> normal-time index-time))
t)
More information about the Elephant-cvs
mailing list