Update of /project/elephant/cvsroot/elephant/tests
In directory common-lisp.net:/tmp/cvs-serv30677/tests
Modified Files:
elephant-tests.lisp mop-tests.lisp testcollections.lisp
testserializer.lisp
Added Files:
testmigration.lisp
Log Message:
This is the big merger from the SQL-BACK-END branch.
Date: Wed Nov 23 18:52:00 2005
Author: rread
Index: elephant/tests/testmigration.lisp
diff -u /dev/null elephant/tests/testmigration.lisp:1.2
--- /dev/null Wed Nov 23 18:52:01 2005
+++ elephant/tests/testmigration.lisp Wed Nov 23 18:51:59 2005
@@ -0,0 +1,170 @@
+;; This file can really only be used if you
+;; have preformed both:
+;; (asdf:operate 'asdf:load-op :ele-bdb)
+;; and
+;; (asdf:operate 'asdf:load-op :ele-clsql)
+
+(in-package :ele-tests)
+
+(deftest remove-element
+ (let ((a (vector 'a 'b 'c))
+ (ans (vector 'a 'c)))
+ (setf a (ele::remove-indexed-element-and-adjust 1 a))
+ (and (equal (aref a 0) (aref ans 0))
+ (equal (aref a 1) (aref ans 1))
+ (equal (length a) (length ans))))
+ t)
+
+
+(deftest migrate1
+ (let ((old-store *store-controller*)
+ (*prev-commit* *auto-commit*)
+ (*auto-commit* t)
+ (rv nil))
+ (unwind-protect
+ (let (
+ (sc1 (open-store *test-path-primary*))
+ (sc2 (open-store *test-path-secondary*)))
+ (add-to-root "x" "y" :store-controller sc1)
+ (copy-from-key "x" sc1 sc2)
+ (setf rv (equal (get-from-root "x" :store-controller sc1)
+ (get-from-root "x" :store-controller sc2))))
+ (progn
+ (setq *store-controller* old-store)
+ (setq *auto-commit* *prev-commit*)))
+ rv)
+ t)
+
+
+(deftest migrate2
+ (let ((old-store *store-controller*)
+ (*prev-commit* *auto-commit*)
+ (*auto-commit* t)
+ (rv nil))
+ (unwind-protect
+ (let
+ ((sc1 (open-store *test-path-primary*))
+ (sc2 (open-store *test-path-secondary*)))
+ (let ((ibt (build-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*))))
+ nil)
+
+
+(deftest migrate3
+ (let ((old-store *store-controller*)
+ (*prev-commit* *auto-commit*)
+ (*auto-commit* t)
+ (rv nil))
+ (unwind-protect
+ (let ((sc1 (open-store *test-path-primary*))
+ (sc2 (open-store *test-path-secondary*))
+ )
+ (let* ((ibt (build-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 (gethash 'crunch (indices ibt))))
+ (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)
+ t)
+
+
+(deftest migrate4
+ (finishes
+ (let ((old-store *store-controller*)
+ (*prev-commit* *auto-commit*)
+ (*auto-commit* t)
+ (rv nil))
+ (unwind-protect
+ (let* (
+ (sc1 (open-store *test-path-primary*))
+ (sc2 (open-store *test-path-secondary*))
+ )
+ (let* ((ibt (build-indexed-btree sc1)))
+ (let (
+ (index
+ (add-index ibt :index-name 'crunch :key-form 'crunch
+ :populate t))
+ (x 0)
+ )
+ (loop for i from 0 to 10
+ do
+ (setf (get-value i ibt) (* i i)))
+ )))
+ (progn
+ (setq *store-controller* old-store)
+ (setq *auto-commit* *prev-commit*)))
+ ))
+ t)
+
+(deftest migrate5
+ (finishes
+ (let ((old-store *store-controller*)
+ (*prev-commit* *auto-commit*)
+ (*auto-commit* t))
+ (unwind-protect
+ (let ((osc (if (subtypep (type-of *store-controller*) 'sql-store-controller)
+ (open-store *test-path-primary*)
+ (open-store *test-path-secondary*)
+ )))
+;; really need to test the an error is thrown when attempting to migrate
+;; non-persistent object!
+ (let* ((f1 (make-instance 'pfoo :sc *store-controller*))
+ (f2 (make-instance 'pfoo :slot1 "this is a string" :sc *store-controller*))
+ (b1 (make-instance 'pbar :slot2 "another string" :sc *store-controller*))
+ )
+ (let ((fm1
+ (ele::migraten-pobj
+ osc f1
+ #'(lambda (dst src)
+ (if (slot-boundp src 'slot1)
+ (setf (slot1 dst) (slot1 src))))))
+ (fm2
+ (ele::migraten-pobj
+ osc f2
+ #'(lambda (dst src)
+ (if (slot-boundp src 'slot1)
+ (setf (slot1 dst) (slot1 src))))))
+ (bm1 (ele::migraten-pobj
+ osc b1
+ #'(lambda (dst src)
+ (if (slot-boundp src 'slot2)
+ (setf (slot2 dst) (slot2 src))))))
+ )
+ (and
+ (and (not (slot-boundp fm1 'slot1))
+ (not (slot-boundp f1 'slot1)))
+ (equal (slot1 fm2) (slot1 f2))
+ (equal (slot2 bm1) (slot2 b1))))))
+ (progn
+ (setq *store-controller* old-store)
+ (setq *auto-commit* *prev-commit*))))
+ )
+ t)
Index: elephant/tests/elephant-tests.lisp
diff -u elephant/tests/elephant-tests.lisp:1.5 elephant/tests/elephant-tests.lisp:1.6
--- elephant/tests/elephant-tests.lisp:1.5 Thu Feb 24 02:07:51 2005
+++ elephant/tests/elephant-tests.lisp Wed Nov 23 18:51:59 2005
@@ -81,6 +81,9 @@
(in-package :ele-tests)
+;; Putting this in to make the test work; I have no idea what it means...
+(deftype array-or-pointer-char () '(or array t))
+
(defvar *testdb-path*
;;"/usr/local/share/common-lisp/elephant-0.2/tests/testdb"
@@ -93,11 +96,50 @@
;;"/usr/local/share/common-lisp/elephant-0.2/tests/testdb"
(namestring
(merge-pathnames
- #p"tests/sleepycatdb/"
+ #p"tests/testsleepycat/"
(asdf:component-pathname (asdf:find-system 'elephant-tests)))))
+(defvar *testpg-path*
+'(:postgresql "localhost.localdomain" "test" "postgres" ""))
+
+(defvar *testsqlite3-path*
+;; This is of the form '(filename &optional init-function),
+;; and using :memory: as a file name will get you an completely in-memory system...
+;; '(":memory:")
+ '(:sqlite3 "sqlite3-test.db")
+)
+
+(defvar *test-path-primary*
+ *testpg-path*
+)
+(defvar *test-path-secondary*
+ *testdb-path*
+)
+
+
(defun do-all-tests()
- (with-open-store (*testdb-path*)
+ (progn
+ (do-all-tests-spec *testdb-path*)
+ (do-all-tests-spec *testpg-path*)
+ ))
+
+(defun do-crazy-pg-tests()
+ (open-store *testpg-path*)
+ (do-test 'indexed-btree-make)
+ (do-test 'add-indices)
+ (do-test 'test-indices)
+ (do-test 'indexed-put)
+ (do-test 'indexed-get)
+ (close-store)
+ )
+
+(defun do-migrate-test-spec(spud)
+ (with-open-store(spud)
+ (let ((*auto-commit* nil))
+ (do-test 'migrate1))))
+
+(defun do-all-tests-spec(spec)
+ (with-open-store (spec)
(let ((*auto-commit* nil))
(do-tests))))
@@ -132,4 +174,4 @@
(defmacro are-not-null (&rest forms)
`(values
,@(loop for form in forms
- collect `(is-not-null ,form))))
\ No newline at end of file
+ collect `(is-not-null ,form))))
Index: elephant/tests/mop-tests.lisp
diff -u elephant/tests/mop-tests.lisp:1.7 elephant/tests/mop-tests.lisp:1.8
--- elephant/tests/mop-tests.lisp:1.7 Thu Feb 24 02:07:51 2005
+++ elephant/tests/mop-tests.lisp Wed Nov 23 18:51:59 2005
@@ -139,14 +139,14 @@
(deftest initform-test
(let ((*auto-commit* t))
- (slot-value (make-instance 'p-initform-test) 'slot1))
+ (slot-value (make-instance 'p-initform-test :sc *store-controller*) 'slot1))
10)
(deftest initarg-test
(let ((*auto-commit* t))
(values
- (slot-value (make-instance 'p-initform-test-2) 'slot1)
- (slot-value (make-instance 'p-initform-test-2 :slot1 20) 'slot1)))
+ (slot-value (make-instance 'p-initform-test-2 :sc *store-controller*) 'slot1)
+ (slot-value (make-instance 'p-initform-test-2 :slot1 20 :sc *store-controller*) 'slot1)))
10 20)
(deftest no-eval-initform
@@ -155,7 +155,7 @@
((slot1 :initarg :slot1 :initform (error "Shouldn't be called")))
(:metaclass persistent-metaclass))
(let ((*auto-commit* t))
- (make-instance 'no-eval-initform :slot1 "something"))
+ (make-instance 'no-eval-initform :slot1 "something" :sc *store-controller* ))
t)
t)
@@ -168,8 +168,8 @@
;; i wish i could use slot-makunbound but allegro sux
(deftest makunbound
- (let ((p (make-instance 'p-class)))
- (with-transaction ()
+ (let ((p (make-instance 'p-class :sc *store-controller*)))
+ (with-transaction (:store-controller *store-controller*)
(setf (slot1 p) t)
#-allegro
(slot-makunbound p 'slot1)
@@ -186,7 +186,7 @@
((slot1 :initform 1 :accessor slot1))
(:metaclass persistent-metaclass))
(let* ((*auto-commit* t)
- (foo (make-instance 'update-class)))
+ (foo (make-instance 'update-class :sc *store-controller*)))
(defclass update-class ()
((slot2 :initform 2 :accessor slot2))
(:metaclass persistent-metaclass))
@@ -207,7 +207,7 @@
(:metaclass persistent-metaclass))
(let* ((*auto-commit* t)
- (foo (make-instance 'class-one)))
+ (foo (make-instance 'class-one :sc *store-controller*)))
(change-class foo (find-class 'class-two))
(values
(slot1 foo)
@@ -215,9 +215,13 @@
1 2)
(deftest change-class2
- (with-transaction ()
- (let ((foo (make-instance 'btree)))
- (change-class foo (find-class 'indexed-btree))
+ (with-transaction (:store-controller *store-controller*)
+ (let ((foo (build-btree *store-controller*)))
+ (change-class foo (find-class
+ (if (typep *store-controller* 'bdb-store-controller)
+ 'bdb-indexed-btree
+ 'sql-indexed-btree)
+ ))
(is-not-null (indices foo))))
t)
@@ -233,7 +237,7 @@
(:metaclass persistent-metaclass))
(let* ((*auto-commit* t)
- (foo (make-instance 'class-one)))
+ (foo (make-instance 'class-one :sc *store-controller*)))
(change-class foo (find-class 'class-two))
(values
(slot1 foo)
Index: elephant/tests/testcollections.lisp
diff -u elephant/tests/testcollections.lisp:1.3 elephant/tests/testcollections.lisp:1.4
--- elephant/tests/testcollections.lisp:1.3 Thu Feb 24 02:06:05 2005
+++ elephant/tests/testcollections.lisp Wed Nov 23 18:51:59 2005
@@ -1,12 +1,29 @@
(in-package :ele-tests)
+(deftest basicpersistence
+ (let ((old-store *store-controller*)
+ (*prev-commit* *auto-commit*)
+ (*auto-commit* t)
+ (rv nil))
+ (unwind-protect
+ (let ((x (gensym)))
+ (add-to-root "x" x)
+ (let ((sc1 (open-store *test-path-primary*)))
+ (setf rv (equal (format nil "~A" x)
+ (format nil "~A" (get-from-root "x"))))))
+ (progn
+ (setq *store-controller* old-store)
+ (setq *auto-commit* *prev-commit*)))
+ rv)
+ t
+)
+
(deftest testoid
(progn
(ele::next-oid *store-controller*)
(let ((oid (ele::next-oid *store-controller*)))
- (with-open-store (*testdb-path*)
- (< oid (ele::next-oid *store-controller*)))))
+ (< oid (ele::next-oid *store-controller*))))
t)
(defclass blob ()
@@ -24,17 +41,23 @@
(defvar bt)
(deftest btree-make
- (finishes (setq bt (make-instance 'btree)))
+ (finishes (setq bt (build-btree *store-controller*)))
t)
-(setq *auto-commit* nil)
+;; This is a very dangerous and naughty statement.
+;; It was probably placed in this file for a good reason,
+;; but nothing seems to reset it. The result is that after loading
+;; theses tests, nothing works as you expect it later.
+;; It may be that the proper fix is not just to take it out,
+;; but that is the best that I can do right now.
+;; (setq *auto-commit* nil)
(deftest btree-put
(finishes
- (with-transaction ()
- (loop for obj in objs
- for key in keys
- do (setf (get-value key bt) obj))))
+ (with-transaction (:store-controller *store-controller*)
+ (loop for obj in objs
+ for key in keys
+ do (setf (get-value key bt) obj))))
t)
(deftest btree-get
@@ -48,8 +71,13 @@
(defvar first-key (first keys))
+
+;; For some unkown reason, this fails on my server unless
+;; I put the variable "first-key" here rather than use the string
+;; "key-1". I need to understand this, but don't at present....
(deftest remove-kv
- (finishes (with-transaction () (remove-kv first-key bt)))
+ (finishes
+ (with-transaction (:store-controller *store-controller*) (remove-kv "key-1" bt)))
t)
(deftest removed
@@ -66,13 +94,14 @@
(subsetp (cdr keys) ks :test #'equalp))))
t)
+;; I hate global variables! Yuck!
(defvar indexed)
(defvar index1)
(defvar index2)
(deftest indexed-btree-make
- (finishes (with-transaction ()
- (setq indexed (make-instance 'indexed-btree))))
+ (finishes (with-transaction (:store-controller *store-controller*)
+ (setq indexed (build-indexed-btree *store-controller*))))
t)
(defun key-maker (s key value)
@@ -81,7 +110,7 @@
(deftest add-indices
(finishes
- (with-transaction ()
+ (with-transaction (:store-controller *store-controller*)
(setf index1
(add-index indexed :index-name 'slot1 :key-form 'key-maker))
(setf index2
@@ -116,10 +145,10 @@
(deftest indexed-put
(finishes
- (with-transaction ()
+ (with-transaction (:store-controller *store-controller*)
(loop for obj in objs
- for key in keys
- do (setf (get-value key indexed) obj))))
+ for key in keys
+ do (setf (get-value key indexed) obj))))
t)
(deftest indexed-get
@@ -131,6 +160,16 @@
(= (slot2 obj) (* i 100))))
t)
+
+(deftest simple-slot-get
+ (progn
+ (setf (get-value (nth 0 keys) indexed) (nth 0 objs))
+ (let ((obj
+ (get-value 1 index1)))
+ (and (= (slot1 obj) 1)
+ (= (slot2 obj) (* 1 100)))))
+t)
+
(deftest indexed-get-from-slot1
(loop with index = (get-index indexed 'slot1)
for i from 1 to 1000
@@ -158,10 +197,10 @@
(get-primary-key 100 index2))
nil nil nil)
+
(deftest remove-kv-from-slot1
(finishes (remove-kv 2 index1))
t)
-
(deftest no-key-nor-indices-slot1
(values
(get-value (second keys) indexed)
@@ -172,7 +211,6 @@
(deftest remove-kv-from-slot2
(finishes (remove-kv 300 index2))
t)
-
(deftest no-key-nor-indices-slot2
(values
(get-value (third keys) indexed)
@@ -190,8 +228,11 @@
(subsetp (cdddr keys) ks :test #'equalp))))
t)
+;; This is "4" below because they have removed the
+;; first three keys, and are testing that the index reflect this,
+;; and my code doesn't.
(deftest get-first
- (with-transaction ()
+ (with-transaction (:store-controller *store-controller*)
(with-btree-cursor (c index1)
(multiple-value-bind (has k v)
(cursor-first c)
@@ -200,7 +241,7 @@
t)
(deftest get-first2
- (with-transaction ()
+ (with-transaction (:store-controller *store-controller*)
(with-btree-cursor (c index2)
(multiple-value-bind (has k v)
(cursor-first c)
@@ -209,7 +250,7 @@
t)
(deftest get-last
- (with-transaction ()
+ (with-transaction (:store-controller *store-controller*)
(with-btree-cursor (c index1)
(multiple-value-bind (has k v)
(cursor-last c)
@@ -218,7 +259,7 @@
t)
(deftest get-last2
- (with-transaction ()
+ (with-transaction (:store-controller *store-controller*)
(with-btree-cursor (c index2)
(multiple-value-bind (has k v)
(cursor-last c)
@@ -227,7 +268,7 @@
t)
(deftest set
- (with-transaction ()
+ (with-transaction (:store-controller *store-controller*)
(with-btree-cursor (c index1)
(multiple-value-bind (has k v)
(cursor-set c 200)
@@ -236,7 +277,7 @@
t)
(deftest set2
- (with-transaction ()
+ (with-transaction (:store-controller *store-controller*)
(with-btree-cursor (c index2)
(multiple-value-bind (has k v)
(cursor-set c 500)
@@ -245,7 +286,7 @@
t)
(deftest set-range
- (with-transaction ()
+ (with-transaction (:store-controller *store-controller*)
(with-btree-cursor (c index1)
(multiple-value-bind (has k v)
(cursor-set-range c 199.5)
@@ -254,7 +295,7 @@
t)
(deftest set-range2
- (with-transaction ()
+ (with-transaction (:store-controller *store-controller*)
(with-btree-cursor (c index2)
(multiple-value-bind (has k v)
(cursor-set-range c 501)
@@ -262,12 +303,75 @@
(= (slot2 v) 600))))
t)
+(deftest rem-kv
+ (with-transaction (:store-controller *store-controller*)
+ (let ((ibt (build-indexed-btree *store-controller*)))
+ (loop for i from 0 to 10
+ do
+ (setf (get-value i ibt) (* i i)))
+ (remove-kv 0 ibt)
+ (remove-kv 1 ibt)
+ (remove-kv 10 ibt)
+ (equal (list
+ (get-value 0 ibt)
+ (get-value 1 ibt)
+ (get-value 10 ibt)
+ (get-value 5 ibt)
+ )
+ '(nil nil nil 25))
+ ))
+t
+ )
+
+(defun odd (s k v)
+ (declare (ignore s k))
+ (values t (mod v 2)
+))
+
+(deftest rem-idexkv
+ (with-transaction (:store-controller *store-controller*)
+ (let* ((ibt (build-indexed-btree *store-controller*))
+ (id1 (add-index ibt :index-name 'idx1 :key-form 'odd)))
+ (loop for i from 0 to 10
+ do
+ (setf (get-value i ibt) (* i i)))
+
+ (with-btree-cursor (c id1)
+ (cursor-first c)
+ (dotimes (i 10)
+ (multiple-value-bind (has key value)
+ (cursor-next c)
+ ))
+ )
+ (remove-kv 4 ibt)
+ (remove-kv 5 ibt)
+
+ (equal (list
+ (get-value 4 ibt)
+ (get-value 5 ibt)
+ (get-value 6 ibt)
+ (with-btree-cursor (c ibt)
+ (cursor-first c)
+ (dotimes (i 4)
+ (multiple-value-bind (has key value)
+ (cursor-next c)
+ value))
+ (multiple-value-bind (has key value)
+ (cursor-next c)
+ value
+ )
+ ))
+ '(nil nil 36 49)
+ )))
+ t
+ )
+
(defvar indexed2)
(defvar index3)
(deftest make-indexed2
- (finishes (with-transaction ()
- (setq indexed2 (make-instance 'indexed-btree))))
+ (finishes (with-transaction (:store-controller *store-controller*)
+ (setq indexed2 (build-indexed-btree *store-controller*))))
t)
(defun crunch (s k v)
@@ -276,14 +380,14 @@
(deftest add-indices2
(finishes
- (with-transaction ()
+ (with-transaction (:store-controller *store-controller*)
(setq index3
(add-index indexed2 :index-name 'crunch :key-form 'crunch))))
t)
(deftest put-indexed2
(finishes
- (with-transaction ()
+ (with-transaction (:store-controller *store-controller*)
(loop for i from 0 to 10000
do
(setf (get-value i indexed2) (- i)))))
@@ -295,13 +399,12 @@
t)
(deftest get-from-index3
- (loop for i from 0 to 1000
- always (= (* i -10) (get-value i index3)))
- t)
-
+ (loop for i from 0 to 1000
+ always (= (* i -10) (get-value i index3)))
+ t)
(deftest dup-test
- (with-transaction ()
+ (with-transaction (:store-controller *store-controller*)
(with-btree-cursor (curs index3)
(loop for (more k v) = (multiple-value-list
(cursor-first curs))
@@ -311,8 +414,9 @@
(0 -1 -2 -3 -4 -5 -6 -7 -8 -9))
+
(deftest nodup-test
- (with-transaction ()
+ (with-transaction (:store-controller *store-controller*)
(with-btree-cursor (curs index3)
(loop for (m k v) = (multiple-value-list (cursor-next-nodup curs))
for i from 0 downto -9990 by 10
@@ -321,7 +425,7 @@
t)
(deftest prev-nodup-test
- (with-transaction ()
+ (with-transaction (:store-controller *store-controller*)
(with-btree-cursor (curs index3)
(cursor-last curs)
(loop for (m k v) = (multiple-value-list (cursor-prev-nodup curs))
@@ -331,7 +435,7 @@
t)
(deftest pnodup-test
- (with-transaction ()
+ (with-transaction (:store-controller *store-controller*)
(with-btree-cursor (curs index3)
(loop for (m k v p) = (multiple-value-list (cursor-pnext-nodup curs))
for i from 0 to 9990 by 10
@@ -340,7 +444,7 @@
t)
(deftest pprev-nodup-test
- (with-transaction ()
+ (with-transaction (:store-controller *store-controller*)
(with-btree-cursor (curs index3)
(cursor-last curs)
(loop for (m k v p) = (multiple-value-list (cursor-pprev-nodup curs))
@@ -349,9 +453,36 @@
always (= p i))))
t)
+(deftest cur-del1
+ ;; Note: If this is not done inside a transaction,
+ ;; it HANGS BDB!
+ (with-transaction (:store-controller *store-controller*)
+ (let* ((ibt (build-indexed-btree *store-controller*))
+ (id1 (add-index ibt :index-name 'idx1 :key-form 'odd)))
+ (loop for i from 0 to 10
+ do
+ (setf (get-value i ibt) (* i i)))
+;; This appears to delete the SINGLE value pointed two by
+;; the cursor at that time. (the way it is written now, the second-to-last element 9 = 81;
+;; If you want to delete more, you have to iterate through the cursor, I suppose.
+ (with-btree-cursor (c id1)
+ (cursor-last c)
+ (cursor-delete c)
+ )
+ (equal
+ (list
+ (get-value 4 ibt)
+ (get-value 5 ibt)
+ (get-value 9 ibt)
+ (get-value 10 ibt)
+ )
+ '(16 25 nil 100))
+ ))
+ t)
+
(deftest indexed-delete
(finishes
- (with-transaction ()
+ (with-transaction (:store-controller *store-controller*)
(with-btree-cursor (curs index3)
(cursor-last curs)
(cursor-delete curs))))
@@ -365,7 +496,7 @@
(deftest indexed-delete2
(finishes
- (with-transaction ()
+ (with-transaction (:store-controller *store-controller*)
(with-btree-cursor (curs index3)
(cursor-first curs)
(cursor-next-dup curs)
@@ -383,6 +514,29 @@
v)))
0 0 nil -2)
+
+(deftest cur-del2
+ (with-transaction (:store-controller *store-controller*)
+ (let* ((ibt (build-indexed-btree *store-controller*))
+ (id1 (add-index ibt :index-name 'idx1 :key-form 'odd)))
+ (loop for i from 0 to 10
+ do
+ (setf (get-value i ibt) (* i i)))
+ (with-btree-cursor (c id1)
+ (cursor-first c)
+ (cursor-next-dup c)
+ (cursor-delete c)
+ )
+ (equal (list
+ (get-value 1 id1) ;;
+ (get-value 0 id1) ;; This should be 0, but is returning nil!
+ )
+ '(1 0))
+ ))
+ t)
+
+
+
(deftest get-both
(with-btree-cursor (c indexed2)
(cursor-get-both c 200 -200))
@@ -414,12 +568,15 @@
(pcursor-pkey (cursor-pfirst c))
(pcursor-pkey (cursor-pnext c))
(pcursor-pkey (cursor-pnext-nodup c))
+
(pcursor-pkey (cursor-pnext-dup c))
(pcursor-pkey (cursor-pprev c))
(pcursor-pkey (cursor-pprev-nodup c))
+
(pcursor-pkey (cursor-plast c))
(pcursor-pkey (cursor-pset c 300))
(pcursor-pkey (cursor-pset-range c 199.5))
+
(pcursor-pkey (cursor-pget-both c 10 101))
(pcursor-pkey (cursor-pget-both-range c 11 111.4))))
@@ -429,7 +586,7 @@
(deftest newindex
(finishes
- (with-transaction ()
+ (with-transaction (:store-controller *store-controller*)
(setq index4
(add-index indexed2 :index-name 'crunch :key-form 'crunch
:populate t))))
@@ -451,3 +608,105 @@
(pcursor-pkey (cursor-pget-both-range c 11 111.4))))
0 2 10 11 10 9 9999 3000 2000 101 112)
+
+
+(deftest add-get-remove
+ (let ((r1 '())
+ (r2 '())
+ (*prev-commit* *auto-commit*))
+ (unwind-protect
+ (progn
+ (setq *auto-commit* t)
+ (add-to-root "x1" "y1")
+ (add-to-root "x2" "y2")
+ (setf r1 (get-from-root "x1"))
+ (setf r2 (get-from-root "x2"))
+ (remove-from-root "x1")
+ (remove-from-root "x2")
+ (and
+ (equal "y1" r1)
+ (equal "y2" r2)
+ (equal nil (get-from-root "x1"))
+ (equal nil (get-from-root "x2"))
+ )
+ )
+ (setq *auto-commit* *prev-commit*)
+ ))
+ t)
+
+(deftest add-get-remove-symbol
+ (let ((foo (cons nil nil))
+ (bar (cons 'a 'b))
+ (f1 '())
+ (f2 '())
+ (b1 '())
+ (b2 '())
+ (*prev-commit* *auto-commit*))
+ (unwind-protect
+ (progn
+ (setq *auto-commit* t)
+ (add-to-root "my key" foo)
+ (add-to-root "my other key" foo)
+ (setf f1 (get-from-root "my key"))
+ (setf f2 (get-from-root "my other key"))
+ (add-to-root "my key" bar)
+ (add-to-root "my other key" bar)
+ (setf b1 (get-from-root "my key"))
+ (setf b2 (get-from-root "my other key"))
+ (and
+ (equal f1 f2)
+ (equal b1 b2)
+ (equal f1 foo)
+ (equal b1 bar)
+ ))
+ (setq *auto-commit* *prev-commit*)
+ ))
+ t)
+
+(deftest existsp
+ (let ((exists1 '())
+ (exists2 '())
+ (exists3 '())
+ (key "my key")
+ (*prev-commit* *auto-commit*)
+ )
+ (unwind-protect
+ (progn
+ (setq *auto-commit* t)
+ (remove-from-root key)
+ (setf exists1
+ (from-root-existsp key)
+ )
+ (add-to-root key 'a)
+ (setf exists2 (from-root-existsp key))
+ (remove-from-root key)
+ (setf exists3 (from-root-existsp key))
+ )
+ (setq *auto-commit* *prev-commit*)
+ )
+ (values exists1 exists2 exists3)
+ )
+ nil t nil
+ )
+
+
+;; This test not only does not work, it appears to
+;; hang sleepycat forcing a recovery!?!?!?!
+;; (deftest cursor-put
+;; (let* ((ibt (build-indexed-btree *store-controller*)))
+;; (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)))
+;; ;; Now create a cursor, advance and put...
+;; (let ((c (make-cursor ibt)))
+;; (cursor-next c)
+;; (cursor-next c)
+;; (cursor-put c 4 :key 10)
+;; (equal (get-value 10 ibt) 4)))
+;; )
+;; t)
Index: elephant/tests/testserializer.lisp
diff -u elephant/tests/testserializer.lisp:1.6 elephant/tests/testserializer.lisp:1.7
--- elephant/tests/testserializer.lisp:1.6 Thu Feb 24 02:06:05 2005
+++ elephant/tests/testserializer.lisp Wed Nov 23 18:51:59 2005
@@ -2,19 +2,19 @@
(defun in-out-value (var)
(with-buffer-streams (out-buf)
- (deserialize (serialize var out-buf))))
+ (deserialize (serialize var out-buf) :sc *store-controller*)))
(defun in-out-eq (var)
(with-buffer-streams (out-buf)
- (eq var (deserialize (serialize var out-buf)))))
+ (eq var (deserialize (serialize var out-buf) :sc *store-controller*))))
(defun in-out-equal (var)
(with-buffer-streams (out-buf)
- (equal var (deserialize (serialize var out-buf)))))
+ (equal var (deserialize (serialize var out-buf) :sc *store-controller*))))
(defun in-out-equalp (var)
(with-buffer-streams (out-buf)
- (equalp var (deserialize (serialize var out-buf)))))
+ (equalp var (deserialize (serialize var out-buf) :sc *store-controller*))))
(deftest fixnums
(are-not-null
@@ -33,7 +33,7 @@
(typep (in-out-value most-positive-fixnum) 'fixnum)
(typep (in-out-value most-negative-fixnum) 'fixnum))
t t t t t)
-
+
(deftest bignums
(are-not-null
(in-out-equal 10000000000)
@@ -114,7 +114,7 @@
(defun in-out-uninterned-equal (var)
(with-buffer-streams (out-buf)
(serialize var out-buf)
- (let ((new (deserialize (serialize var out-buf))))
+ (let ((new (deserialize (serialize var out-buf) :sc *store-controller*)))
(and (equal (symbol-name new) (symbol-name var))
(equal (symbol-package new) (symbol-package var))))))
@@ -299,7 +299,7 @@
(defun in-out-deep-equalp (var)
(with-buffer-streams (out-buf)
- (deep-equalp var (deserialize (serialize var out-buf)))))
+ (deep-equalp var (deserialize (serialize var out-buf) :sc *store-controller*))))
(deftest objects
(are-not-null
@@ -315,8 +315,8 @@
(l1 (make-list 100))
(h (make-hash-table :test 'equal))
(g (make-array '(2 3 4)))
- (f (make-instance 'foo))
- (b (make-instance 'bar)))
+ (f (make-instance 'foo ))
+ (b (make-instance 'bar )))
(setf (car c1) c1)
(setf (cdr c1) c1)
(setf (car c2) c1)
@@ -351,11 +351,16 @@
(deftest persistent
(let* ((*auto-commit* t)
- (f1 (make-instance 'pfoo))
- (f2 (make-instance 'pfoo :slot1 "this is a string"))
- (b1 (make-instance 'pbar :slot2 "another string"))
- (b2 (make-instance 'pbar))
- (h (make-instance 'btree)))
+ (f1 (make-instance 'pfoo :sc *store-controller*))
+ (f2 (make-instance 'pfoo :slot1 "this is a string" :sc *store-controller*))
+ (b1 (make-instance 'pbar :slot2 "another string" :sc *store-controller*))
+ (b2 (make-instance 'pbar :sc *store-controller*))
+
+;; Note, this as will will have to be split on clas,s if we we want to
+;; test it both ways...since we won't know how they will want it
+;; implemented, we will have to somehow make a choice here, maybe
+;; based on the stype of *store-controller*
+ (h (build-btree *store-controller*)))
(are-not-null
(in-out-eq f1)
(in-out-eq f2)
@@ -368,4 +373,7 @@
(eq f1 (slot1 f1)))
(progn (setf (get-value f2 h) f2)
(eq (get-value f2 h) f2))))
- t t t t t t t t)
+ t t t t t t t t)
+
+
+
