[elephant-cvs] CVS elephant/tests
rread
rread at common-lisp.net
Tue Feb 7 23:23:51 UTC 2006
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)
+
+
+
+
More information about the Elephant-cvs
mailing list