[elephant-cvs] CVS elephant/tests

[ieslick]

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

Modified Files:
	elephant-tests.lisp testmigration.lisp 
Log Message:
Added functionality and test for migrating persistent references inside lisp aggregates: array, list and hash tables

--- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp	2007/02/26 19:12:19	1.26
+++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp	2007/03/11 03:31:10	1.27
@@ -145,6 +145,7 @@
     (print (do-test 'migrate-btree))
     (print (do-test 'migrate-idx-btree))
     (print (do-test 'migrate-pclass))
+    (print (do-test 'migrate-mult-pclass))
     (print (do-test 'migrate-ipclass))))
     
 (defun do-migration-test-spec (test spec1 spec2)
--- /project/elephant/cvsroot/elephant/tests/testmigration.lisp	2007/02/03 04:09:14	1.14
+++ /project/elephant/cvsroot/elephant/tests/testmigration.lisp	2007/03/11 03:31:10	1.15
@@ -65,7 +65,7 @@
 		      do
 		      (setf (get-value i ibt) (* i i))))
 		 (let ((mig (migrate sc2 ibt)))
-		   (btree-differ ibt mig)))
+		   (btree-differ-p ibt mig)))
 	    (close-store sc1)
 	    (close-store sc2))))
   nil)
@@ -103,7 +103,7 @@
 		       (progn
 			 (format t "YIKES ~A ~%" i)
 			 )))
-		(not (btree-differ ibt mig)))))
+		(not (btree-differ-p ibt mig)))))
 	  (progn
 	    (setq *store-controller* old-store)
 	    (close-store sc1)
@@ -144,6 +144,45 @@
 	    (close-store sc2))))
   t)
 
+(deftest migrate-mult-pclass 
+    (progn
+      (let* ((*store-controller* nil)
+	     (sc1 (open-store *test-spec-primary* :recover t :deadlock-detect t))
+	     (sc2 (open-store *test-spec-secondary* :recover t :deadlock-detect t)))
+	(unwind-protect
+	     (progn (elephant::reset-migrate-duplicate-detection)
+		    (let* ((simplesrc (make-instance 'pfoo :slot1 0 :sc sc1))
+			   (i1 (make-instance 'pfoo :slot1 1 :sc sc1))
+			   (i2 (make-instance 'pfoo :slot1 2 :sc sc1))
+			   (i3 (make-instance 'pfoo :slot1 3 :sc sc1))
+			   (list (list i1 i1))
+			   (array (make-array '(2 2) :initial-contents `((,i2 1)
+									 (,i2 2))))
+			   (hash (make-hash-table)))
+	    (setf (gethash 1 hash) i3)
+	    (setf (gethash 2 hash) i3)
+	    (let* ((newsimple (migrate sc2 simplesrc))
+		   (newlist (migrate sc2 list))
+		   (newarray (migrate sc2 array))
+		   (newhash (migrate sc2 hash)))
+		(values (and (and (slot-boundp newsimple 'slot1)
+				  (eq (slot1 newsimple) 0)))
+			(and (not (eq i1 (first newlist)))
+			     (eq (first newlist) (second newlist))
+			     (and (slot-boundp (first newlist) 'slot1)
+				  (eq (slot1 (first newlist)) 1)))
+			(and (not (eq i2 (aref newarray 0 0)))
+			     (eq (aref newarray 0 0) (aref newarray 1 0))
+			     (and (slot-boundp (aref newarray 0 0) 'slot1)
+				  (eq (slot1 (aref newarray 0 0)) 2)))
+			(and (not (eq i3 (gethash 1 newhash)))
+			     (eq (gethash 1 newhash) (gethash 2 newhash))
+			     (and (slot-boundp (gethash 1 newhash) 'slot1)
+				  (eq (slot1 (gethash 1 newhash)) 3)))))))
+	  (close-store sc1)
+	  (close-store sc2))))
+  t t t t t t t t t t)
+
 (defpclass ipfoo ()
   ((slot1 :accessor slot1 :initarg :slot1 :index t)))
 
@@ -167,7 +206,7 @@
 		     (remove-kv 'ipfoo (elephant::controller-class-root sc2)))
 		   (setf (elephant::%index-cache (find-class 'ipfoo)) nil)
 		   (find-class-index 'ipfoo :sc sc1)
-		   (format t "Making objects~%")
+;;		   (format t "Making objects~%")
 ;;		   (with-transaction (:store-controller sc2)
 ;;		     (drop-instances (get-instances-by-class 'ipfoo) :sc sc2))
 		   (with-transaction (:store-controller sc1 :retries 2)
@@ -175,12 +214,12 @@
 		     (make-instance 'ipfoo :slot1 1 :sc sc1)
 		     (make-instance 'ipfoo :slot1 10 :sc sc1)
 		     (make-instance 'ipfoo :slot1 20 :sc sc1))
-		   (format t "Migrating~%")
+;;		   (format t "Migrating~%")
 		   (migrate sc2 sc1)
 		   ;; Make sure our ipfoo class now points at a cache in sc2!
 		   (assert (equal (elephant::controller-spec sc2)
-				  (:dbcn-spc-pst (elephant::%index-cache (find-class 'ipfoo)))))
-		   (format t "Fetching~%")
+				  (elephant::dbcn-spc-pst (elephant::%index-cache (find-class 'ipfoo)))))
+;;		   (format t "Fetching~%")
 		   (let ((fm1 (get-instances-by-value 'ipfoo 'slot1 1))
 			 (fm2 (get-instances-by-value 'ipfoo 'slot1 10))
 			 (fm3 (get-instances-by-value 'ipfoo 'slot1 20))