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))