[elephant-cvs] CVS elephant/tests - elephant-cvs@common-lisp.net - mailman3.common-lisp.net

20 Feb 2006

Update of /project/elephant/cvsroot/elephant/tests
In directory common-lisp:/tmp/cvs-serv24854/tests
Modified Files:
    elephant-tests.lisp testmigration.lisp 
Log Message:
Migration implementation; indexed class migration is broken but all else passes basic tests

--- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp	2006/02/19 17:25:53	1.15
+++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp	2006/02/20 15:45:38	1.16
@@ -129,12 +129,17 @@
    (*test-spec-secondary* spec2))
     (declare (special *test-spec-primary* *test-spec-secondary*))
     (print (do-test 'remove-element))
-    (print (do-test 'migrate1))
-    (print (do-test 'migrate2))
-    (print (do-test 'migrate3))
-    (print (do-test 'migrate4))
-    (print (do-test 'migrate5))))
+    (print (do-test 'migrate-basic))
+    (print (do-test 'migrate-btree))
+    (print (do-test 'migrate-idx-btree))
+    (print (do-test 'migrate-pclass))))
+;;    (print (do-test 'migrate-ipclass))))
+(defun do-migration-test-spec (test spec1 spec2)
+  (let ((*test-spec-primary* spec1)
+	(*test-spec-secondary* spec2))
+    (declare (special *test-spec-primary* *test-spec-secondary*))
+    (print (do-test test))))
;;
--- /project/elephant/cvsroot/elephant/tests/testmigration.lisp	2006/02/19 04:53:02	1.7
+++ /project/elephant/cvsroot/elephant/tests/testmigration.lisp	2006/02/20 15:45:38	1.8
@@ -13,6 +13,14 @@
(in-package :ele-tests)
+;; TEST TODO:
+;; - inhibited slot copy & user overloading of migrate methodss
+;; - proper use of clearing the tracking of copies 
+;;   (oids not same over two copys of same object)
+;; - whole repository migration (write comparison method to sanity check)
+;; - transient slot migration is correct (online transfer of state to new repos)
+;; - 
+
 (deftest remove-element
     (if (or (not (boundp '*test-spec-secondary*))
        (null *test-spec-secondary*))
@@ -27,7 +35,8 @@
           (equal (length a) (length ans)))))
   t)
-(deftest migrate1
+;; Simple root element copy
+(deftest migrate-basic
     (if (or (not (boundp '*test-spec-secondary*) )
        (null *test-spec-secondary*))
    (progn
@@ -41,10 +50,10 @@
      (sc2 nil))
       (unwind-protect 
       (progn
-	     (setf sc1 (open-store *test-spec-primary*))
-	     (setf sc2 (open-store *test-spec-secondary*))
+	     (setf sc1 (open-store *test-spec-primary* :recover t))
+	     (setf sc2 (open-store *test-spec-secondary* :recover t))
         (add-to-root "x" "y" :store-controller sc1)
-	     (copy-from-key "x" sc1 sc2)
+	     (migrate sc2 sc1)
         (setf rv (equal (get-from-root "x" :store-controller sc1)
    		     (get-from-root "x" :store-controller sc2))))
    (progn
@@ -55,8 +64,8 @@
       rv))
     t)
-
-(deftest migrate2
+;; Simple test of a btree
+(deftest migrate-btree
     (if (or (not (boundp '*test-spec-secondary*) )
        (null *test-spec-secondary*))
    (progn
@@ -70,7 +79,7 @@
       (let
           ((sc1 (open-store *test-spec-primary*))
    	(sc2 (open-store *test-spec-secondary*)))
-	     (let ((ibt (build-btree sc1)))
+	     (let ((ibt (make-btree sc1)))
           (loop for i from 0 to 10
    	  do
    	    (setf (get-value i ibt) (* i i)))
@@ -81,8 +90,8 @@
          (setq *auto-commit* *prev-commit*)))))
   nil)
-
-(deftest migrate3
+;; Simple test of indexed btrees
+(deftest migrate-idx-btree
     (if (or (not (boundp '*test-spec-secondary*) )
        (null *test-spec-secondary*))
    (progn
@@ -96,23 +105,21 @@
       (let ((sc1 (open-store *test-spec-primary*))
    	 (sc2 (open-store *test-spec-secondary*))
    	 )
-	     (let* ((ibt (build-indexed-btree sc1)))
-	       (let (
-		     (index
+	     (let* ((ibt (make-indexed-btree sc1)))
+	       (let ((index
    	      (add-index ibt :index-name 'crunch :key-form 'crunch
-				 :populate t))
-		     )
+				 :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))))
+			(nindex (get-index ibt 'crunch)))
    	   (loop for i from 0 to 10
    	      do
    	      (if (not 
    		   (equal
    		    (get-value i index)
-			    (get-value i nindex)			
+			    (get-value i nindex)
    		    ))
    		  (progn
    		    (format t "YIKES ~A ~%" i)
@@ -126,79 +133,72 @@
       ))
   t)
-
-(deftest migrate4
+;; Simple test of persistent classes
+(deftest migrate-pclass
     (if (or (not (boundp '*test-spec-secondary*) )
        (null *test-spec-secondary*))
    (progn
      (format t "~%Single store mode: ignoring")
      t)
-    (finishes
-      (let ((old-store *store-controller*)
-	    (*prev-commit* *auto-commit*)
-	    (*auto-commit* t)
-	    (rv nil))
-	(unwind-protect 
-	     (let* (
-		   (sc1 (open-store *test-spec-primary*))
-		   (sc2 (open-store *test-spec-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*)))
-      )))
+	(let ((*prev-commit* *auto-commit*))
+	  (unwind-protect
+	       (prog2 
+		   (setq *auto-commit* t)
+		   (let (
+			 (sc1 (open-store *test-spec-primary*))
+			 (sc2 (open-store *test-spec-secondary*)))
+		     (let* ((f1 (make-instance 'pfoo  :sc sc1))
+			    (f2 (make-instance 'pfoo :slot1 "this is a string"  :sc sc1))
+			    (b1 (make-instance 'pbar :slot2 "another string"  :sc sc1))
+			    )		 
+		       (let ((fm1 (migrate sc2 f1))
+			     (fm2 (migrate sc2 f2))
+			     (bm1 (migrate sc2 b1)))
+			 (and 
+			  (and (not (slot-boundp fm1 'slot1))
+			       (not (slot-boundp f1 'slot1)))
+			  (equal (slot1 fm2) (slot1 f2))
+			  (equal (slot2 bm1) (slot2 b1)))
+			 ))))
+	    (setq *auto-commit* *prev-commit*))))
   t)
-(deftest migrate5
+(defpclass ipfoo ()
+  ((slot1 :accessor slot1 :initarg :slot1 :index t)))
+
+;; Simple test of persistent classes with indexed slots
+(deftest migrate-ipclass
     (if (or (not (boundp '*test-spec-secondary*) )
        (null *test-spec-secondary*))
    (progn
      (format t "~%Single store mode: ignoring")
      t)
    (let ((*prev-commit* *auto-commit*))
-	  (prog2 
-	      (setq *auto-commit* t)
-	      (let (
-		    (sc1 (open-store *test-spec-primary*))
-		    (sc2 (open-store *test-spec-secondary*)))
-		(let* ((f1 (make-instance 'pfoo  :sc sc1))
-		       (f2 (make-instance 'pfoo :slot1 "this is a string"  :sc sc1))
-		       (b1 (make-instance 'pbar :slot2 "another string"  :sc sc1))
-		       )		 
-		  (let ((fm1 
-			 (migrate ;; (ele::migraten-pobj 
-			  sc2 f1
-			  #'(lambda (dst src)
-			      (if (slot-boundp src 'slot1)
-				  (setf (slot1 dst) (slot1 src))))))
-		      (fm2 
-		       (migrate ;; (ele::migraten-pobj 
-			sc2 f2
-			#'(lambda (dst src)
-			    (if (slot-boundp src 'slot1)
-				(setf (slot1 dst) (slot1 src))))))
-		      (bm1 (migrate ;; (ele::migraten-pobj 
-			    sc2 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))
-		   ))))
-	  (setq *auto-commit* *prev-commit*))))
-	  t)
+	  (unwind-protect
+	       (prog2 
+		   (setq *auto-commit* t)
+		   (let ((sc1 (open-store *test-spec-primary*))
+			 (sc2 (open-store *test-spec-secondary*)))
+		     ;; ensure class index is initialized in sc1
+		     (find-class-index 'ipfoo :sc sc1) 
+		     (let* ((f1 (make-instance 'ipfoo :sc sc1))
+			    (f2 (make-instance 'ipfoo :slot1 10))
+			    (f3 (make-instance 'ipfoo :slot1 20)))
+		       (format t "Made instances")
+		       (let ((fm1 (migrate sc2 f1))
+			     (fm2 (migrate sc2 f2))
+			     (fm3 (migrate sc2 f3)))
+			 (format t "Migrated instances")
+			 (values
+			  (and 
+			   (and (not (slot-boundp fm1 'slot1))
+				(not (slot-boundp f1 'slot1)))
+			   (equal (slot1 fm2) (slot1 f2))
+			   (equal (slot2 fm3) (slot2 f3)))
+			  (length (get-instances-by-class 'ipfoo)))
+			 ))))
+	    (setq *auto-commit* *prev-commit*))))
+  t 2 )
+
+
+

    