[elephant-cvs] CVS elephant/tests

[rread]

Update of /project/elephant/cvsroot/elephant/tests
In directory clnet:/tmp/cvs-serv22716/tests

Modified Files:
	testindexing.lisp 
Log Message:
Workaround for SBCL 0.9.9 weirdness and making the tests repeatably runnable.


--- /project/elephant/cvsroot/elephant/tests/testindexing.lisp	2006/02/27 16:49:49	1.14
+++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp	2006/03/01 18:57:34	1.15
@@ -24,51 +24,83 @@
 (defvar inst2)
 (defvar inst3)
 
-(deftest indexing-basic-trivial
+(deftest disable-class-indexing-test
     (progn
-      (disable-class-indexing 'idx-one  :sc *store-controller* :errorp nil)
+      (when (find-class 'idx-one nil)
+	(disable-class-indexing 'idx-one  :errorp nil)
+	(setf (find-class 'idx-one) nil))
+      
+      (defclass idx-one ()
+	((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t))
+	(:metaclass persistent-metaclass))
+
+      
+      (disable-class-indexing 'idx-one  :errorp nil)
+      (disable-class-indexing 'idx-one  :errorp nil)
       (setf (find-class 'idx-one) nil)
+      t)
+t)
+
+(deftest indexing-basic-trivial
+    (progn
+      (when (class-indexedp-by-name 'idx-one)
+	(disable-class-indexing 'idx-one  :errorp nil)
+	(setf (find-class 'idx-one) nil))
       
       (defclass idx-one ()
 	((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t))
 	(:metaclass persistent-metaclass))
-      (length (get-instances-by-class 'idx-one))
+      (defmethod print-object ((obj idx-one) stream)
+	(if (slot-boundp obj 'slot1)
+	    (format stream "slot1 = ~A~%" (slot1 obj))
+	    (format stream "slot1 unbound~&")
+	))
       (with-transaction (:store-controller *store-controller*)
-	(setq inst1 (make-instance 'idx-one :slot1 1 :sc *store-controller*)))
+	(setq inst1 (make-instance 'idx-one :slot1 101 :sc *store-controller*))
+	(setq inst1 (make-instance 'idx-one :slot1 101 :sc *store-controller*))
+	)
 ;; The real problem is that this call doesn't seem to see it, and the make-instance
 ;; doesn't seem to think it needs to write anything!
       (length (get-instances-by-class 'idx-one))
-      (length (get-instances-by-class 'idx-one))
+       (disable-class-indexing 'idx-one  :sc *store-controller* :errorp nil)
+       (setf (find-class 'idx-one) nil)
+       (signals-error (get-instances-by-class 'idx-one))
       )
-  1)
+  t)
 
 ;; put list of objects, retrieve on value, range and by class
 (deftest indexing-basic
-    (progn
+    (let ((n 105))
       ;;(format t "Global vars:~%")
       ;;(format t "~%basic store: ~A  ~A~%" *store-controller* (elephant::controller-spec *store-controller*))
 ;;      (format t "auto-commit: ~A~%" *auto-commit*)
 
-      (when (find-class 'idx-one nil)
+      (when (class-indexedp-by-name 'idx-one )
 	(disable-class-indexing 'idx-one :errorp nil)
 	(setf (find-class 'idx-one nil) nil))
       
       (defclass idx-one ()
 	((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t))
 	(:metaclass persistent-metaclass))
+      (defmethod print-object ((obj idx-one) stream)
+	(if (slot-boundp obj 'slot1)
+	    (format stream "slot1 = ~A~%" (slot1 obj))
+	    (format stream "slot1 unbound~&")
+	))
 
       (progn
 	(with-transaction (:store-controller *store-controller*)
-	  (setq inst1 (make-instance 'idx-one :slot1 40 :sc *store-controller*))
-	  (setq inst2 (make-instance 'idx-one :slot1 40 :sc *store-controller*))
-	  (setq inst3 (make-instance 'idx-one :slot1 41 :sc *store-controller*)))
+	  (setq inst1 (make-instance 'idx-one :slot1 n :sc *store-controller*))
+	  (setq inst2 (make-instance 'idx-one :slot1 n :sc *store-controller*))
+	  (setq inst3 (make-instance 'idx-one :slot1 (+ 1 n) :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 40))
-		(length (get-instances-by-value 'idx-one 'slot1 41))
-		(equal (first (get-instances-by-value 'idx-one 'slot1 41)) inst3)
-		(length (get-instances-by-range 'idx-one 'slot1 40 41)))))
+ 	(values (length (get-instances-by-class 'idx-one))
+ 		(length (get-instances-by-value 'idx-one 'slot1 n))
+ 		(length (get-instances-by-value 'idx-one 'slot1 (+ 1 n)))
+ 		(equal (first (get-instances-by-value 'idx-one 'slot1 (+ 1 n))) inst3)
+ 		(length (get-instances-by-range 'idx-one 'slot1 n (+ 1 n))))
+	))
   3 2 1 t 3)
 
 ;; test inherited slots
@@ -76,11 +108,11 @@
     (progn 
 ;;      (format t "inherit store: ~A  ~A~%" *store-controller* (controller-path *store-controller*))
 
-      (when (find-class 'idx-two nil)
+      (when (class-indexedp-by-name 'idx-two )
 	(disable-class-indexing 'idx-two :sc *store-controller* :errorp nil)
 	(setf (find-class 'idx-two) nil))
 
-      (when (find-class 'idx-three nil)
+      (when (class-indexedp-by-name 'idx-three )
 	(disable-class-indexing 'idx-three :sc *store-controller* :errorp nil)
 	(setf (find-class 'idx-three) nil))
 
@@ -120,13 +152,17 @@
 (deftest indexing-range
     (progn
       ;;      (format t "range store: ~A  ~A~%" *store-controller* (controller-path *store-controller*))
-      (when (find-class 'idx-four nil)
+      (when (class-indexedp-by-name 'idx-four )
+	(defclass idx-four ()
+	  ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t))
+	  (:metaclass persistent-metaclass))
 	(disable-class-indexing 'idx-four :errorp nil)
 	(setf (find-class 'idx-four nil) nil))
-      
-      (defclass idx-four ()
+
+	(defclass idx-four ()
 	((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t))
 	(:metaclass persistent-metaclass))
+      
 
       (defun make-idx-four (val)
 	(make-instance 'idx-four :slot1 val))
@@ -153,9 +189,9 @@
 
 (deftest indexing-wipe-index
     (progn 
-      (when (find-class 'idx-five-del nil)
-	(disable-class-indexing 'idx-five :errorp nil)
-	(setf (find-class 'idx-five) nil))
+      (when (class-indexedp-by-name 'idx-five-del )
+	(disable-class-indexing 'idx-five-del :errorp nil)
+	(setf (find-class 'idx-five-del) nil))
 
       (defclass idx-five-del ()
 	((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t))
@@ -178,7 +214,12 @@
 
 (deftest indexing-reconnect-db
     (progn 
-      (when (find-class 'idx-five nil)
+      (when (class-indexedp-by-name 'idx-five)
+	(defclass idx-five ()
+	  ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t)
+	   (slot2 :initarg :slot2 :initform 2 :accessor slot2)
+	   (slot3 :initarg :slot3 :initform 3 :accessor slot3 :index t))
+	  (:metaclass persistent-metaclass))
 	(disable-class-indexing 'idx-five :errorp nil)
 	(setf (find-class 'idx-five) nil))
       
@@ -215,10 +256,19 @@
 (deftest indexing-change-class 
     (progn
 
-      (when (find-class 'idx-six nil)
+      (when (class-indexedp-by-name 'idx-six)
+	(defclass idx-six ()
+	  ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t)
+	   (slot2 :initarg :slot2 :initform 2 :accessor slot2 :index t))
+	  (:metaclass persistent-metaclass))
 	(disable-class-indexing 'idx-six :errorp nil)
 	(setf (find-class 'idx-six) nil))
-      (when (find-class 'idx-seven nil)
+      (when (class-indexedp-by-name 'idx-seven)
+	(defclass idx-seven ()
+	  ((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))
 	(disable-class-indexing 'idx-seven :errorp nil)
 	(setf (find-class 'idx-seven) nil))
 
@@ -265,7 +315,14 @@
 
 (deftest indexing-redef-class
     (progn
-      (when (find-class 'idx-eight nil)
+      (when (class-indexedp-by-name 'idx-eight)
+	(defclass idx-eight ()
+	  ((slot1 :accessor slot1 :initarg :slot1 :index t)
+	   (slot2 :accessor slot2 :initarg :slot2)
+	   (slot3 :accessor slot3 :initarg :slot3 :transient t)
+	   (slot4 :accessor slot4 :initarg :slot4 :index t)
+	   (slot5 :accessor slot5 :initarg :slot5))
+	  (:metaclass persistent-metaclass))
 	(disable-class-indexing 'idx-eight :errorp nil)
 	(setf (find-class 'idx-eight nil) nil))