Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv9614/tests
Modified Files: elephant-tests.lisp testcollections.lisp Added Files: RunIndexingTutorial.lisp testindexing.lisp Log Message: Merger from Ian's branch into the main trunk.
--- /project/elephant/cvsroot/elephant/tests/RunIndexingTutorial.lisp 2006/02/05 23:44:26 1.1 +++ /project/elephant/cvsroot/elephant/tests/RunIndexingTutorial.lisp 2006/02/07 23:23:51 1.2 @@ -0,0 +1,39 @@ +(asdf:operate 'asdf:load-op :elephant) +(asdf:operate 'asdf:load-op :ele-bdb) +(asdf:operate 'asdf:load-op :elephant-tests) + +(compile-file "indexing.lisp") +(load "index-tutorial.lisp") + +(in-package "ELEPHANT-TUTORIAL") +(defconstant KILO 1000) +(defun test-generate-and-report-big (num name store-spec) + (open-store store-spec) + (generate-events name num 0.0 ) + (report-events name) + (close-store)) + +(defun find-mid-event (name) + (let ((midpoint (floor (/ (+ *start-timestamp* + *end-timestamp*) 2)))) + (report-events-by-time-only name + midpoint + (+ midpoint)) + ) +) + +(defun report-events-by-time-only (user start end) + "A custom reporting function for our logs - pull out a time range. A real + implementation might do it by dates or by dates + times using one of the + lisp time libraries" + (let ((entries1 (time (get-instances-by-range 'url-log 'timestamp start end))) + (entries2 nil)) + (mapc #'(lambda (x) (if (equal (plog-user x) user) (push x entries2))) entries1) + (format t "Event logs for ~A (~A range, ~A user):~%" user (length entries1) (length entries2)) +)) + + +(time (test-generate-and-report-big (* 10 KILO) "bud" ele-tests::*test-path-primary*)) +(open-store ele-tests::*test-path-primary*) +(time (find-mid-event "bud")) +(close-store) --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/04 22:25:10 1.9 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/07 23:23:51 1.10 @@ -92,17 +92,48 @@ (defvar *test-path-primary* *testdb-path* ) + (defvar *test-path-secondary* *testdb-path2* )
- (defun do-all-tests() (progn (do-all-tests-spec *testdb-path*) (do-all-tests-spec *testsqlite3-path*) ))
+(defun do-all-tests-spec (spec) + (when spec + (with-open-store (spec) + (let ((*auto-commit* nil)) + (declare (special *auto-commit*)) + (do-tests))))) + +(defun do-test-spec (testname &optional (spec *testdb-path*)) + "For easy interactive running of tests while debugging" + (when spec + (with-open-store (spec) + (let ((*auto-commit* nil)) + (do-test testname))))) + +(defun do-indexing-tests () + (declare (special *old-store*)) + (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)) + (setq *store-controller* *old-store*))) + (defun do-crazy-pg-tests() (open-store *testpg-path*) (do-test 'indexed-btree-make) --- /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2006/02/05 23:13:08 1.10 +++ /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2006/02/07 23:23:51 1.11 @@ -215,6 +215,7 @@ (deftest remove-kv-from-slot1 (finishes (remove-kv 2 index1)) t) + (deftest no-key-nor-indices-slot1 (values (get-value (second keys) indexed) @@ -225,6 +226,7 @@ (deftest remove-kv-from-slot2 (finishes (remove-kv 300 index2)) t) + (deftest no-key-nor-indices-slot2 (values (get-value (third keys) indexed) --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/01/29 04:57:21 1.1 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/07 23:23:51 1.2 @@ -0,0 +1,235 @@ + +(in-package :ele-tests) + +(defun setup-testing () + (setf rt::*debug* t) + (setf rt::*catch-errors* nil) +;; (trace elephant::indexed-slot-writer) + (trace ((method initialize-instance :before (persistent)))) + (trace ((method initialize-instance (persistent-object)))) +;; (trace ((method shared-initialize :around (persistent-object t)))) +;; (trace ((method shared-initialize :around (persistent-metaclass t)))) +;; (trace elephant::find-class-index) +;; (trace get-instances-by-class) +;; (trace get-instances-by-value) + (trace enable-class-indexing) + (trace get-instances-by-range) + (trace elephant::cache-instance) + (trace elephant::get-cached-instance) + (trace elephant::get-cache) + (trace elephant::db-transaction-commit) + ) + +;; put list of objects, retrieve on value, range and by class +(deftest indexing-basic + (progn +;; (format t "Global vars:~%") +;; (format t "~%basic store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) +;; (format t "auto-commit: ~A~%" *auto-commit*) + (disable-class-indexing 'idx-one :errorp nil) + (setf (find-class 'idx-one) nil) + + (defclass idx-one () + ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :indexed t)) + (:metaclass persistent-metaclass)) + + (progn + (with-transaction () + (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*))) + +;; (format t "Starting gathering of instances~%") + (values (length (get-instances-by-class 'idx-one)) + (length (get-instances-by-value 'idx-one 'slot1 1)) + (length (get-instances-by-value 'idx-one 'slot1 3)) + (eq (first (get-instances-by-value 'idx-one 'slot1 3)) inst3) + (length (get-instances-by-range 'idx-one 'slot1 1 3))))) + 3 2 1 t 3) + +;; test inherited slots +(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 () + ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :indexed t) + (slot2 :initarg :slot2 :initform 2 :accessor slot2 :indexed 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)) + (:metaclass persistent-metaclass)) + + (progn + (with-transaction () + (setq inst1 (make-instance 'idx-two :sc *store-controller*))) + + (values (slot1 inst1) + (slot2 inst1) + (slot3 inst1) + (slot4 inst1) + (equal (elephant::indexing-record-slots (elephant::indexed-record (find-class 'idx-two))) + '(slot1 slot3 slot4))))) + 1 20 30 40 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) + (setf (find-class 'idx-one) nil) + + (defclass idx-one () + ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :indexed t)) + (:metaclass persistent-metaclass)) + + (defun make-idx-one (val) + (make-instance 'idx-one :slot1 val :sc *store-controller*)) + + (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) + +(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*)) + + (defclass idx-two () + ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :indexed t) + (slot2 :initarg :slot2 :initform 2 :accessor slot2) + (slot3 :initarg :slot3 :initform 3 :accessor slot3 :indexed t)) + (:metaclass persistent-metaclass)) + + (let ((*old-default* *default-indexed-class-synch-policy*) + (*default-indexed-class-synch-policy* :db)) + + (with-transaction () + (make-instance 'idx-two)) + + ;; Wipe out the class so it's not a redefinition + (setf (find-class 'idx-two) nil) + + ;; 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)) + (:metaclass persistent-metaclass)) + + ;; Add an instance of the new class + (with-transaction () + (make-instance 'idx-two)) + + ;; 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)))))) + 2 2 t) + +(deftest indexing-change-class + nil + nil) + +(deftest indexing-redef-class + nil + nil) + +(deftest indexing-explicit-changes + nil + nil) + +;; 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)) + (: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)) + (:metaclass persistent-metaclass)) + +(defvar normal-index nil) + +(defun normal-stress-setup (count class-name &rest inst-args) + (setf normal-index (make-btree)) + (dotimes (i count) + (setf (get-value i normal-index) (apply #'make-instance class-name :stress1 i inst-args)))) + +(defun indexed-stress-setup (count class-name &rest inst-args) + (dotimes (i count) + (apply #'make-instance class-name :stress1 i inst-args))) + +(defun normal-range-lookup (count size) + "Given stress1 slot has values between 1 and count, extract a range of size size that starts + at (/ count 2)" + (let* ((objects nil) + (start (/ count 2)) + (end (1- (+ start size)))) + (with-btree-cursor (cur normal-index) + (multiple-value-bind (value? key val) (cursor-next cur) + (declare (ignore key)) + (when (and value? + (>= (stress1 val) start) + (<= (stress1 val) end)) + (push val objects)))) + objects)) + +(defun indexed-range-lookup (class count size) + (let* ((start (/ count 2)) + (end (1- (+ start size)))) + (get-instances-by-range class 'stress1 start end))) + +(defparameter *stress-count* 500) +(defparameter *range-size* 40) + +(deftest indexing-timing + (progn + + (let ((insts (get-instances-by-class 'stress-index))) + (when insts + (drop-instances insts))) + + (format t "~%Stress test normal setup time (~A):~%" *stress-count*) + (with-transaction () + (time (normal-stress-setup *stress-count* 'stress-normal :stress2 10))) + + (format t "~%Stress test indexed setup time (~A):~%" *stress-count*) + (with-transaction () + (time (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 indexed lookup time (~A):~%" *range-size*) + (time + (dotimes (i *range-size*) + (declare (ignore i)) + (indexed-range-lookup 'stress-index *stress-count* *range-size*))) + t) + t) + + + +