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)